<commit_before>/*
*
*  This software was developed by the Thermal Modeling and Analysis
*  Project(TMAP) of the National Oceanographic and Atmospheric
*  Administration's (NOAA) Pacific Marine Environmental Lab(PMEL),
*  hereafter referred to as NOAA/PMEL/TMAP.
*
*  Access and use of this software shall impose the following
*  obligations and understandings on the user. The user is granted the
*  right, without any fee or cost, to use, copy, modify, alter, enhance
*  and distribute this software, and any derivative works thereof, and
*  its supporting documentation for any purpose whatsoever, provided
*  that this entire notice appears in all copies of the software,
*  derivative works and supporting documentation.  Further, the user
*  agrees to credit NOAA/PMEL/TMAP in any publications that result from
*  the use of this software or in any product that includes this
*  software. The names TMAP, NOAA and/or PMEL, however, may not be used
*  in any advertising or publicity to endorse or promote any products
*  or commercial entity unless specific written permission is obtained
*  from NOAA/PMEL/TMAP. The user also understands that NOAA/PMEL/TMAP
*  is not obligated to provide the user with any support, consulting,
*  training or assistance of any kind with regard to the use, operation
*  and performance of this software nor to provide the user with any
*  updates, revisions, new versions or "bug fixes".
*
*  THIS SOFTWARE IS PROVIDED BY NOAA/PMEL/TMAP "AS IS" AND ANY EXPRESS
*  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
*  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
*  ARE DISCLAIMED. IN NO EVENT SHALL NOAA/PMEL/TMAP BE LIABLE FOR ANY SPECIAL,
*  INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
*  RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
*  CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, ARISING OUT OF OR IN
*  CONNECTION WITH THE ACCESS, USE OR PERFORMANCE OF THIS SOFTWARE.
*
*/



/* EF_InternalUtil.c
 *
 * <NAME>
 * Sep 4th 1997
 *
 * This file contains all the utility functions which Ferret
 * needs in order to communicate with an external function.
 */


/* .................... Includes .................... */
 
#include <unistd.h>		/* for convenience */
#include <stdio.h>		/* for convenience */
#include <stdlib.h>		/* for convenience */
#include <string.h>		/* for convenience */
#include <fcntl.h>		/* for fcntl() */
#include <dlfcn.h>		/* for dynamic linking */
#include <signal.h>             /* for signal() */
#include <setjmp.h>             /* required for jmp_buf */

#include <sys/types.h>	        /* required for some of our prototypes */
#include <sys/stat.h>
#include <sys/errno.h>

#include "EF_Util.h"
#include "list.h"  /* locally added list library */


/* ................ Global Variables ................ */
/*
 * The memory_ptr, mr_list_ptr and cx_list_ptr are obtained from Ferret
 * and cached whenever they are passed into one of the "efcn_" functions.
 * These pointers can be accessed by the utility functions in efn_ext/.
 * This way the EF writer does not need to see these pointers.
 */

static LIST  *GLOBAL_ExternalFunctionList;
float *GLOBAL_memory_ptr;
int   *GLOBAL_mr_list_ptr;
int   *GLOBAL_cx_list_ptr;
int   *GLOBAL_mres_ptr;
float *GLOBAL_bad_flag_ptr;

/*
 * The jumpbuffer is used by setjmp() and longjmp().
 * setjmp() is called by FORTRAN(efcn_compute)() in EF_InternalUtil.c and
 * saves the stack environment in jumpbuffer for later use by longjmp().
 * This allows one to bail out of external functions and still
 * return control to Ferret.
 * Check "Advanced Progrmming in the UNIX Environment" by Stevens
 * sections 7.10 and 10.14 to understand what's going on with these.
 */
static jmp_buf jumpbuffer;
static sigjmp_buf sigjumpbuffer;
static volatile sig_atomic_t canjump;

static int I_have_scanned_already = FALSE;
static int I_have_warned_already = TRUE; /* Warning turned off Jan '98 */


/* ............. Function Declarations .............. */
/*
 * Note that all routines called directly from Ferret,
 * ie. directly from Fortran, should be all lower case,
 * be of type 'void', pass by reference and should end with 
 * an underscore.
 */


/* .... Functions called by Ferret .... */

int  FORTRAN(efcn_scan)( int * );
int  FORTRAN(efcn_already_have_internals)( int * );

int  FORTRAN(efcn_gather_info)( int * );
void FORTRAN(efcn_get_custom_axes)( int *, int * );
void FORTRAN(efcn_get_result_limits)( int *, float *, int *, int * );
void FORTRAN(efcn_compute)( int *, int *, int *, int *, int *, float *, int *, float *, int * );


void FORTRAN(efcn_get_custom_axis_sub)( int *, int *, float *, float *, float *, char *, int * );

int  FORTRAN(efcn_get_id)( char * );
int  FORTRAN(efcn_match_template)( int *, char * );

void FORTRAN(efcn_get_name)( int *, char * );
void FORTRAN(efcn_get_version)( int *, float * );
void FORTRAN(efcn_get_descr)( int *, char * );
int  FORTRAN(efcn_get_num_reqd_args)( int * );
void FORTRAN(efcn_get_has_vari_args)( int *, int * );
void FORTRAN(efcn_get_axis_will_be)( int *, int * );
void FORTRAN(efcn_get_axis_reduction)( int *, int * );
void FORTRAN(efcn_get_piecemeal_ok)( int *, int * );

void FORTRAN(efcn_get_axis_implied_from)( int *, int *, int * );
void FORTRAN(efcn_get_axis_extend_lo)( int *, int *, int * );
void FORTRAN(efcn_get_axis_extend_hi)( int *, int *, int * );
void FORTRAN(efcn_get_axis_limits)( int *, int *, int *, int * );
int  FORTRAN(efcn_get_arg_type)( int *, int *);
void FORTRAN(efcn_get_arg_name)( int *, int *, char * );
void FORTRAN(efcn_get_arg_unit)( int *, int *, char * );
void FORTRAN(efcn_get_arg_desc)( int *, int *, char * );


/* .... Functions called internally .... */

/* Fortran routines from the efn/ directory */
void FORTRAN(efcn_copy_array_dims)(void);
void FORTRAN(efcn_set_work_array_dims)(int *, int *, int *, int *, int *, int *, int *, int *, int *);
void FORTRAN(efcn_get_workspace_addr)(float *, int *, float *);

static void EF_signal_handler(int);
static void (*fpe_handler)(int);
static void (*segv_handler)(int);
static void (*int_handler)(int);
static void (*bus_handler)(int);


void FORTRAN(ef_err_bail_out)(int *, char *);

void EF_store_globals(float *, int *, int *, int *, float *);

ExternalFunction *ef_ptr_from_id_ptr(int *);

int  EF_ListTraverse_fprintf( char *, char * );
int  EF_ListTraverse_FoundName( char *, char * );
int  EF_ListTraverse_MatchTemplate( char *, char * );
int  EF_ListTraverse_FoundID( char *, char * );

int  EF_New( ExternalFunction * );


/* .............. Function Definitions .............. */


/* .... Functions for use by Ferret (to be called from Fortran) .... */

/*
 * Note that all routines called directly from Ferret,
 * ie. directly from Fortran, should be all lower case,
 * should pass by reference and should end with an underscore.
 */

/*
 * Find all of the ~.so files in directories listed in the
 * FER_EXTERNAL_FUNCTIONS environment variable and add all 
 * the names and associated directory information to the 
 * GLOBAL_ExternalFunctionList.
 */
int FORTRAN(efcn_scan)( int *gfcn_num_internal )
{
  
  FILE *file_ptr=NULL;
  ExternalFunction ef; 
 
  char file[EF_MAX_NAME_LENGTH]="";
  char *path_ptr=NULL, path[8192]="";
  char paths[8192]="", cmd[EF_MAX_DESCRIPTION_LENGTH]="";
  int count=0, status=LIST_OK;

  static int return_val=0; /* static because it needs to exist after the return statement */

  if ( I_have_scanned_already ) {
    return_val = list_size(GLOBAL_ExternalFunctionList);
    return return_val;
  }

  if ( (GLOBAL_ExternalFunctionList = list_init()) == NULL ) {
    fprintf(stderr, "ERROR: efcn_scan: Unable to initialize GLOBAL_ExternalFunctionList.\n");
    return_val = -1;
    return return_val;
  }

  /*
   * - Get all the paths from the "FER_EXTERNAL_FUNCTIONS" environment variable.
   *
   * - While there is another path:
   *    - get the path;
   *    - create a pipe for the "ls -1" command;
   *    - read stdout and use each file name to create another external function entry;
   *
   */

  if ( !getenv("FER_EXTERNAL_FUNCTIONS") ) {
    if ( !I_have_warned_already ) {
      fprintf(stderr, "\
\nWARNING: environment variable FER_EXTERNAL_FUNCTIONS not defined.\n\n");
      I_have_warned_already = TRUE;
    }
    return_val = 0;
    return return_val;
  }

  sprintf(paths, "%s", getenv("FER_EXTERNAL_FUNCTIONS"));
    
  path_ptr = strtok(paths, " \t");

  if ( path_ptr == NULL ) {
 
    fprintf(stderr, "\
\nWARNING:No paths were found in the environment variable FER_EXTERNAL_FUNCTIONS.\n\n");

    return_val = 0;
    return return_val;
 
  } else {
    
    do {

	  strcpy(path, path_ptr);

      if (path[strlen(path)-1] != '/')
        strcat(path, "/"); 

      sprintf(cmd, "ls -1 %s", path);

      /* Open a pipe to the "ls" command */
      if ( (file_ptr = popen(cmd, "r")) == (FILE *) NULL ) {
	    fprintf(stderr, "\nERROR: Cannot open pipe.\n\n");
	    return_val = -1;
	    return return_val;
      }
 
      /*
       * Read a line at a time.
       * Any ~.so files are assumed to be external functions.
       */
      while ( fgets(file, EF_MAX_NAME_LENGTH, file_ptr) != NULL ) {

        char *extension;

	    file[strlen(file)-1] = '\0';   /* chop off the carriage return */
	    extension = &file[strlen(file)-3];
	    if ( strcmp(extension, ".so") == 0 ) {
          file[strlen(file)-3] = '\0'; /* chop off the ".so" */
	      strcpy(ef.path, path);
	      strcpy(ef.name, file);
	      ef.id = *gfcn_num_internal + ++count; /* pre-increment because F arrays start at 1 */
	      ef.already_have_internals = NO;
	      ef.internals_ptr = NULL;
	      list_insert_after(GLOBAL_ExternalFunctionList, &ef, sizeof(ExternalFunction));
	    }

      }
 
      pclose(file_ptr);
 
      path_ptr = strtok(NULL, " \t"); /* get the next directory */
 
    } while ( path_ptr != NULL );

    I_have_scanned_already = TRUE;
  }

  return_val = count;
  return return_val;

}


/*
 * Determine whether an external function has already 
 * had its internals read.
 */
int FORTRAN(efcn_already_have_internals)( int *id_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  int status=LIST_OK;

  static int return_val=0; /* static because it needs to exist after the return statement */

  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return return_val; }

  ef_ptr=(ExternalFunction *)list_curr(GLOBAL_ExternalFunctionList); 

  return_val = ef_ptr->already_have_internals;

  return return_val;
}


/*
 * Find an external function based on its integer ID and
 * gather information describing the function. 
 *
 * Return values:
 *     -1: error occurred, dynamic linking was unsuccessful
 *      0: success
 */
int FORTRAN(efcn_gather_info)( int *id_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  ExternalFunctionInternals *i_ptr=NULL;
  int i=0, j=0;
  char ef_object[1024]="", tempText[EF_MAX_NAME_LENGTH]="", *c;

  static int return_val=0; /* static because it needs to exist after the return statement */

  void *handle;
  void (*f_init_ptr)(int *);


  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return return_val; }

  /*
   * Get a handle for the shared object.
   */
  strcat(ef_object, ef_ptr->path);
  strcat(ef_object, ef_ptr->name);
  strcat(ef_object, ".so");

  /*
   * Following might need to be added to get WebFerret to work
   * Commented out because it's Solaris specific
   * JS
   */
#if 0
  if (dlopen("liballferret.so", RTLD_LAZY | RTLD_GLOBAL) == NULL){
      fprintf(stderr, "  dlerror: %s\n", dlerror());
  }
  if (dlopen(ef_object, RTLD_LAZY | RTLD_GLOBAL) == NULL){
      fprintf(stderr, "  dlerror: %s\n", dlerror());
  }

  ef_ptr->handle = dlopen(0, RTLD_LAZY);
#endif
  /*  if ( (ef_ptr->handle = dlopen(ef_object, RTLD_LAZY)) == NULL ) {*/
  /* if ( (ef_ptr->handle = dlopen(ef_object, RTLD_NOW || RTLD_GLOBAL)) == NULL ) { */
  /* kob - commented out above line, and removed RTLD_GBAL check from below on
     advice of jc - osf didn't have a definition for RTLD_GLOBAL */
  if ( (ef_ptr->handle = dlopen(ef_object, RTLD_NOW)) == NULL ) {
    fprintf(stderr, "\n\
ERROR in External Function %s:\n\
Dynamic linking call dlopen() returns --\n\
\"%s\".\n", ef_ptr->name, dlerror());
    return -1;
  }
  
  /*
   * Allocate and default initialize the internal information.
   * If anything went wrong, return the return_val.
   */
  return_val = EF_New(ef_ptr);

  if ( return_val != 0) {
    return return_val;
  }

  /*
   * Call the external function to really initialize the internal information.
   */
  i_ptr = ef_ptr->internals_ptr;

  if ( i_ptr->language == EF_C ) {

    fprintf(stderr, "\nERROR: C is not a supported language for External Functions.\n\n");
    return_val = -1;
    return return_val;

  } else if ( i_ptr->language == EF_F ) {

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGFPE.\n");
      return;
    }
    if ( (segv_handler = signal(SIGSEGV, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGSEGV.\n");
      return;
    }
    if ( (int_handler = signal(SIGINT, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGINT.\n");
      return;
    }
    if ( (bus_handler = signal(SIGBUS, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGBUS.\n");
      return;
    }
    if (sigsetjmp(sigjumpbuffer, 1) != 0) {
      /* Warning message printed by signal handler. */
      return;
    }
    canjump = 1;

    /* Information about the overall function */

    sprintf(tempText, "");
    strcat(tempText, ef_ptr->name);
    strcat(tempText, "_init_");
    f_init_ptr = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
    if (f_init_ptr == NULL) {
      fprintf(stderr, "ERROR in efcn_gather_info(): %s is not found.\n", tempText);
      fprintf(stderr, "  dlerror: %s\n", dlerror());
      return -1;
    }

    (*f_init_ptr)(id_ptr);

    /*
     * Restore the old signal handlers.
     */
    if (signal(SIGFPE, (*fpe_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGFPE handler.\n");
      return;
    }
    if (signal(SIGSEGV, (*segv_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGSEGV handler.\n");
      return;
    }
    if (signal(SIGINT, (*int_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGINT handler.\n");
      return;
    }
    if (signal(SIGBUS, (*bus_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGBUS handler.\n");
      return;
    }

  }
  
  return 0;
}


/*
 * Find an external function based on its integer ID, 
 * Query the function about custom axes. Store the context
 * list information for use by utility functions.
 */
void FORTRAN(efcn_get_custom_axes)( int *id_ptr, int *cx_list_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  char tempText[EF_MAX_NAME_LENGTH]="";

  void (*fptr)(int *);

  /*
   * Store the context list globally.
   */
  EF_store_globals(NULL, NULL, cx_list_ptr, NULL, NULL);

  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return; }

  if ( ef_ptr->internals_ptr->language == EF_F ) {

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGFPE.\n");
      return;
    }
    if ( (segv_handler = signal(SIGSEGV, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGSEGV.\n");
      return;
    }
    if ( (int_handler = signal(SIGINT, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGINT.\n");
      return;
    }
    if ( (bus_handler = signal(SIGBUS, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGBUS.\n");
      return;
    }
    if (sigsetjmp(sigjumpbuffer, 1) != 0) {
      /* Warning message printed by signal handler. */
      return;
    }
    canjump = 1;

    sprintf(tempText, "");
    strcat(tempText, ef_ptr->name);
    strcat(tempText, "_custom_axes_");

    fptr  = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
    (*fptr)( id_ptr );

    /*
     * Restore the old signal handlers.
     */
    if (signal(SIGFPE, (*fpe_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGFPE handler.\n");
      return;
    }
    if (signal(SIGSEGV, (*segv_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGSEGV handler.\n");
      return;
    }
    if (signal(SIGINT, (*int_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGINT handler.\n");
      return;
    }
    if (signal(SIGBUS, (*bus_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGBUS handler.\n");
      return;
    }

  } else {

    fprintf(stderr, "\nExternal Functions in C are not supported yet.\n\n");

  }

  return;
}


/*
 * Find an external function based on its integer ID, 
 * Query the function about abstract axes. Pass memory,
 * mr_list and cx_list info into the external function.
 */
void FORTRAN(efcn_get_result_limits)( int *id_ptr, float *memory, int *mr_list_ptr, int *cx_list_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  char tempText[EF_MAX_NAME_LENGTH]="";

  void (*fptr)(int *);

  /*
   * Store the memory pointer and various lists globally.
   */
  EF_store_globals(memory, mr_list_ptr, cx_list_ptr, NULL, NULL);

  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return; }

  if ( ef_ptr->internals_ptr->language == EF_F ) {

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGFPE.\n");
      return;
    }
    if ( (segv_handler = signal(SIGSEGV, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGSEGV.\n");
      return;
    }
    if ( (int_handler = signal(SIGINT, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGINT.\n");
      return;
    }
    if ( (bus_handler = signal(SIGBUS, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGBUS.\n");
      return;
    }
    if (sigsetjmp(sigjumpbuffer, 1) != 0) {
      /* Warning message printed by signal handler. */
      return;
    }
    canjump = 1;

    sprintf(tempText, "");
    strcat(tempText, ef_ptr->name);
    strcat(tempText, "_result_limits_");

    fptr  = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
    (*fptr)( id_ptr);

    /*
     * Restore the old signal handlers.
     */
    if (signal(SIGFPE, (*fpe_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGFPE handler.\n");
      return;
    }
    if (signal(SIGSEGV, (*segv_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGSEGV handler.\n");
      return;
    }
    if (signal(SIGINT, (*int_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGINT handler.\n");
      return;
    }
    if (signal(SIGBUS, (*bus_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGBUS handler.\n");
      return;
    }

  } else {

    fprintf(stderr, "\nExternal Functions in C are not supported yet.\n\n");

  }

  return;
}


/*
 * Find an external function based on its integer ID, 
 * pass the necessary information and the data and tell
 * the function to calculate the result.
 */
void FORTRAN(efcn_compute)( int *id_ptr, int *narg_ptr, int *cx_list_ptr, int *mr_list_ptr, int *mres_ptr,
	float *bad_flag_ptr, int *mr_arg_offset_ptr, float *memory, int *status )
{
  ExternalFunction *ef_ptr=NULL;
  ExternalFunctionInternals *i_ptr=NULL;
  float *arg_ptr[EF_MAX_COMPUTE_ARGS];
  int xyzt=0, i=0, j=0;
  int size=0;
  char tempText[EF_MAX_NAME_LENGTH]="";

  /*
   * Prototype all the functions needed for varying numbers of
   * arguments and work arrays.
   */

  void (*fptr)(int *);
  void (*f1arg)(int *, float *, float *);
  void (*f2arg)(int *, float *, float *, float *);
  void (*f3arg)(int *, float *, float *, float *, float *);
  void (*f4arg)(int *, float *, float *, float *, float *, float *);
  void (*f5arg)(int *, float *, float *, float *, float *, float *, float *);
  void (*f6arg)(int *, float *, float *, float *, float *, float *, float *,
		float *);
  void (*f7arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *);
  void (*f8arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *);
  void (*f9arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *);
  void (*f10arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *);
  void (*f11arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *);
  void (*f12arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *);
  void (*f13arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *);
  void (*f14arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *);
  void (*f15arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *);
  void (*f16arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *, float *);
  void (*f17arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *, float *, float *);
  void (*f18arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *, float *, float *, float *);

  /*
   * Initialize the status
   */
  *status = FERR_OK;

  /*
   * Store the array dimensions for memory resident variables and for working storage.
   * Store the memory pointer and various lists globally.
   */
  FORTRAN(efcn_copy_array_dims)();
  EF_store_globals(memory, mr_list_ptr, cx_list_ptr, mres_ptr, bad_flag_ptr);

  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) {
    fprintf(stderr, "\n\
ERROR in efcn_compute() finding external function: id = [%d]\n", *id_ptr);
    *status = FERR_EF_ERROR;
    return;
  }

  i_ptr = ef_ptr->internals_ptr;

  if ( i_ptr->language == EF_F ) {

    /*
     * Begin assigning the arg_ptrs.
     */

    /* First come the arguments to the function. */

     for (i=0; i<i_ptr->num_reqd_args; i++) {
       arg_ptr[i] = memory + mr_arg_offset_ptr[i];
     }

    /* Now for the result */

     arg_ptr[i++] = memory + mr_arg_offset_ptr[EF_MAX_ARGS];

    /* Now for the work arrays */

    /*
     * If this program has requested working storage we need to 
     * ask the function to specify the amount of space needed
     * and then create the memory here.  Memory will be released
     * after the external function returns.
     */
    if (i_ptr->num_work_arrays > EF_MAX_WORK_ARRAYS) {

	  fprintf(stderr, "\n\
ERROR specifying number of work arrays in ~_init subroutine of external function %s\n\
\tnum_work_arrays[=%d] exceeds maximum[=%d].\n\n", ef_ptr->name, i_ptr->num_work_arrays, EF_MAX_WORK_ARRAYS);
	  *status = FERR_EF_ERROR;
	  return;

    } else if (i_ptr->num_work_arrays < 0) {

	  fprintf(stderr, "\n\
ERROR specifying number of work arrays in ~_init subroutine of external function %s\n\
\tnum_work_arrays[=%d] must be a positive number.\n\n", ef_ptr->name, i_ptr->num_work_arrays);
	  *status = FERR_EF_ERROR;
	  return;

    } else if (i_ptr->num_work_arrays > 0)  {

      sprintf(tempText, "");
      strcat(tempText, ef_ptr->name);
      strcat(tempText, "_work_size_");

      fptr = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
      if (fptr == NULL) {
	fprintf(stderr, "\n\
ERROR in efcn_compute() accessing %s\n", tempText);
	*status = FERR_EF_ERROR;
        return;
      }
      (*fptr)( id_ptr );


	  /* Allocate memory for each individual work array */

      for (j=0; j<i_ptr->num_work_arrays; i++, j++) {

        int iarray,xlo,ylo,zlo,tlo,xhi,yhi,zhi,thi;
        iarray = j+1;
        xlo = i_ptr->work_array_lo[j][0];
        ylo = i_ptr->work_array_lo[j][1];
        zlo = i_ptr->work_array_lo[j][2];
        tlo = i_ptr->work_array_lo[j][3];
        xhi = i_ptr->work_array_hi[j][0];
        yhi = i_ptr->work_array_hi[j][1];
        zhi = i_ptr->work_array_hi[j][2];
        thi = i_ptr->work_array_hi[j][3];

        FORTRAN(efcn_set_work_array_dims)(&iarray,&xlo,&ylo,&zlo,&tlo,&xhi,&yhi,&zhi,&thi);

        size = sizeof(float) * (xhi-xlo+1) * (yhi-ylo+1) * (zhi-zlo+1) * (thi-tlo+1);

        if ( (arg_ptr[i] = (float *)malloc(size)) == NULL ) { 
          fprintf(stderr, "\n\
ERROR in efcn_compute() allocating %d words of memory\n", size);
	  *status = FERR_EF_ERROR;
	  return;
        }
      }

    }

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {<commit_msg>Improved error message for malloc() error in efcn_compute.<commit_after>/*
*
*  This software was developed by the Thermal Modeling and Analysis
*  Project(TMAP) of the National Oceanographic and Atmospheric
*  Administration's (NOAA) Pacific Marine Environmental Lab(PMEL),
*  hereafter referred to as NOAA/PMEL/TMAP.
*
*  Access and use of this software shall impose the following
*  obligations and understandings on the user. The user is granted the
*  right, without any fee or cost, to use, copy, modify, alter, enhance
*  and distribute this software, and any derivative works thereof, and
*  its supporting documentation for any purpose whatsoever, provided
*  that this entire notice appears in all copies of the software,
*  derivative works and supporting documentation.  Further, the user
*  agrees to credit NOAA/PMEL/TMAP in any publications that result from
*  the use of this software or in any product that includes this
*  software. The names TMAP, NOAA and/or PMEL, however, may not be used
*  in any advertising or publicity to endorse or promote any products
*  or commercial entity unless specific written permission is obtained
*  from NOAA/PMEL/TMAP. The user also understands that NOAA/PMEL/TMAP
*  is not obligated to provide the user with any support, consulting,
*  training or assistance of any kind with regard to the use, operation
*  and performance of this software nor to provide the user with any
*  updates, revisions, new versions or "bug fixes".
*
*  THIS SOFTWARE IS PROVIDED BY NOAA/PMEL/TMAP "AS IS" AND ANY EXPRESS
*  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
*  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
*  ARE DISCLAIMED. IN NO EVENT SHALL NOAA/PMEL/TMAP BE LIABLE FOR ANY SPECIAL,
*  INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
*  RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
*  CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, ARISING OUT OF OR IN
*  CONNECTION WITH THE ACCESS, USE OR PERFORMANCE OF THIS SOFTWARE.
*
*/



/* EF_InternalUtil.c
 *
 * <NAME>
 * Sep 4th 1997
 *
 * This file contains all the utility functions which Ferret
 * needs in order to communicate with an external function.
 */


/* .................... Includes .................... */
 
#include <unistd.h>		/* for convenience */
#include <stdio.h>		/* for convenience */
#include <stdlib.h>		/* for convenience */
#include <string.h>		/* for convenience */
#include <fcntl.h>		/* for fcntl() */
#include <dlfcn.h>		/* for dynamic linking */
#include <signal.h>             /* for signal() */
#include <setjmp.h>             /* required for jmp_buf */

#include <sys/types.h>	        /* required for some of our prototypes */
#include <sys/stat.h>
#include <sys/errno.h>

#include "EF_Util.h"
#include "list.h"  /* locally added list library */


/* ................ Global Variables ................ */
/*
 * The memory_ptr, mr_list_ptr and cx_list_ptr are obtained from Ferret
 * and cached whenever they are passed into one of the "efcn_" functions.
 * These pointers can be accessed by the utility functions in efn_ext/.
 * This way the EF writer does not need to see these pointers.
 */

static LIST  *GLOBAL_ExternalFunctionList;
float *GLOBAL_memory_ptr;
int   *GLOBAL_mr_list_ptr;
int   *GLOBAL_cx_list_ptr;
int   *GLOBAL_mres_ptr;
float *GLOBAL_bad_flag_ptr;

/*
 * The jumpbuffer is used by setjmp() and longjmp().
 * setjmp() is called by FORTRAN(efcn_compute)() in EF_InternalUtil.c and
 * saves the stack environment in jumpbuffer for later use by longjmp().
 * This allows one to bail out of external functions and still
 * return control to Ferret.
 * Check "Advanced Progrmming in the UNIX Environment" by Stevens
 * sections 7.10 and 10.14 to understand what's going on with these.
 */
static jmp_buf jumpbuffer;
static sigjmp_buf sigjumpbuffer;
static volatile sig_atomic_t canjump;

static int I_have_scanned_already = FALSE;
static int I_have_warned_already = TRUE; /* Warning turned off Jan '98 */


/* ............. Function Declarations .............. */
/*
 * Note that all routines called directly from Ferret,
 * ie. directly from Fortran, should be all lower case,
 * be of type 'void', pass by reference and should end with 
 * an underscore.
 */


/* .... Functions called by Ferret .... */

int  FORTRAN(efcn_scan)( int * );
int  FORTRAN(efcn_already_have_internals)( int * );

int  FORTRAN(efcn_gather_info)( int * );
void FORTRAN(efcn_get_custom_axes)( int *, int * );
void FORTRAN(efcn_get_result_limits)( int *, float *, int *, int * );
void FORTRAN(efcn_compute)( int *, int *, int *, int *, int *, float *, int *, float *, int * );


void FORTRAN(efcn_get_custom_axis_sub)( int *, int *, float *, float *, float *, char *, int * );

int  FORTRAN(efcn_get_id)( char * );
int  FORTRAN(efcn_match_template)( int *, char * );

void FORTRAN(efcn_get_name)( int *, char * );
void FORTRAN(efcn_get_version)( int *, float * );
void FORTRAN(efcn_get_descr)( int *, char * );
int  FORTRAN(efcn_get_num_reqd_args)( int * );
void FORTRAN(efcn_get_has_vari_args)( int *, int * );
void FORTRAN(efcn_get_axis_will_be)( int *, int * );
void FORTRAN(efcn_get_axis_reduction)( int *, int * );
void FORTRAN(efcn_get_piecemeal_ok)( int *, int * );

void FORTRAN(efcn_get_axis_implied_from)( int *, int *, int * );
void FORTRAN(efcn_get_axis_extend_lo)( int *, int *, int * );
void FORTRAN(efcn_get_axis_extend_hi)( int *, int *, int * );
void FORTRAN(efcn_get_axis_limits)( int *, int *, int *, int * );
int  FORTRAN(efcn_get_arg_type)( int *, int *);
void FORTRAN(efcn_get_arg_name)( int *, int *, char * );
void FORTRAN(efcn_get_arg_unit)( int *, int *, char * );
void FORTRAN(efcn_get_arg_desc)( int *, int *, char * );


/* .... Functions called internally .... */

/* Fortran routines from the efn/ directory */
void FORTRAN(efcn_copy_array_dims)(void);
void FORTRAN(efcn_set_work_array_dims)(int *, int *, int *, int *, int *, int *, int *, int *, int *);
void FORTRAN(efcn_get_workspace_addr)(float *, int *, float *);

static void EF_signal_handler(int);
static void (*fpe_handler)(int);
static void (*segv_handler)(int);
static void (*int_handler)(int);
static void (*bus_handler)(int);


void FORTRAN(ef_err_bail_out)(int *, char *);

void EF_store_globals(float *, int *, int *, int *, float *);

ExternalFunction *ef_ptr_from_id_ptr(int *);

int  EF_ListTraverse_fprintf( char *, char * );
int  EF_ListTraverse_FoundName( char *, char * );
int  EF_ListTraverse_MatchTemplate( char *, char * );
int  EF_ListTraverse_FoundID( char *, char * );

int  EF_New( ExternalFunction * );


/* .............. Function Definitions .............. */


/* .... Functions for use by Ferret (to be called from Fortran) .... */

/*
 * Note that all routines called directly from Ferret,
 * ie. directly from Fortran, should be all lower case,
 * should pass by reference and should end with an underscore.
 */

/*
 * Find all of the ~.so files in directories listed in the
 * FER_EXTERNAL_FUNCTIONS environment variable and add all 
 * the names and associated directory information to the 
 * GLOBAL_ExternalFunctionList.
 */
int FORTRAN(efcn_scan)( int *gfcn_num_internal )
{
  
  FILE *file_ptr=NULL;
  ExternalFunction ef; 
 
  char file[EF_MAX_NAME_LENGTH]="";
  char *path_ptr=NULL, path[8192]="";
  char paths[8192]="", cmd[EF_MAX_DESCRIPTION_LENGTH]="";
  int count=0, status=LIST_OK;

  static int return_val=0; /* static because it needs to exist after the return statement */

  if ( I_have_scanned_already ) {
    return_val = list_size(GLOBAL_ExternalFunctionList);
    return return_val;
  }

  if ( (GLOBAL_ExternalFunctionList = list_init()) == NULL ) {
    fprintf(stderr, "ERROR: efcn_scan: Unable to initialize GLOBAL_ExternalFunctionList.\n");
    return_val = -1;
    return return_val;
  }

  /*
   * - Get all the paths from the "FER_EXTERNAL_FUNCTIONS" environment variable.
   *
   * - While there is another path:
   *    - get the path;
   *    - create a pipe for the "ls -1" command;
   *    - read stdout and use each file name to create another external function entry;
   *
   */

  if ( !getenv("FER_EXTERNAL_FUNCTIONS") ) {
    if ( !I_have_warned_already ) {
      fprintf(stderr, "\
\nWARNING: environment variable FER_EXTERNAL_FUNCTIONS not defined.\n\n");
      I_have_warned_already = TRUE;
    }
    return_val = 0;
    return return_val;
  }

  sprintf(paths, "%s", getenv("FER_EXTERNAL_FUNCTIONS"));
    
  path_ptr = strtok(paths, " \t");

  if ( path_ptr == NULL ) {
 
    fprintf(stderr, "\
\nWARNING:No paths were found in the environment variable FER_EXTERNAL_FUNCTIONS.\n\n");

    return_val = 0;
    return return_val;
 
  } else {
    
    do {

	  strcpy(path, path_ptr);

      if (path[strlen(path)-1] != '/')
        strcat(path, "/"); 

      sprintf(cmd, "ls -1 %s", path);

      /* Open a pipe to the "ls" command */
      if ( (file_ptr = popen(cmd, "r")) == (FILE *) NULL ) {
	    fprintf(stderr, "\nERROR: Cannot open pipe.\n\n");
	    return_val = -1;
	    return return_val;
      }
 
      /*
       * Read a line at a time.
       * Any ~.so files are assumed to be external functions.
       */
      while ( fgets(file, EF_MAX_NAME_LENGTH, file_ptr) != NULL ) {

        char *extension;

	    file[strlen(file)-1] = '\0';   /* chop off the carriage return */
	    extension = &file[strlen(file)-3];
	    if ( strcmp(extension, ".so") == 0 ) {
          file[strlen(file)-3] = '\0'; /* chop off the ".so" */
	      strcpy(ef.path, path);
	      strcpy(ef.name, file);
	      ef.id = *gfcn_num_internal + ++count; /* pre-increment because F arrays start at 1 */
	      ef.already_have_internals = NO;
	      ef.internals_ptr = NULL;
	      list_insert_after(GLOBAL_ExternalFunctionList, &ef, sizeof(ExternalFunction));
	    }

      }
 
      pclose(file_ptr);
 
      path_ptr = strtok(NULL, " \t"); /* get the next directory */
 
    } while ( path_ptr != NULL );

    I_have_scanned_already = TRUE;
  }

  return_val = count;
  return return_val;

}


/*
 * Determine whether an external function has already 
 * had its internals read.
 */
int FORTRAN(efcn_already_have_internals)( int *id_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  int status=LIST_OK;

  static int return_val=0; /* static because it needs to exist after the return statement */

  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return return_val; }

  ef_ptr=(ExternalFunction *)list_curr(GLOBAL_ExternalFunctionList); 

  return_val = ef_ptr->already_have_internals;

  return return_val;
}


/*
 * Find an external function based on its integer ID and
 * gather information describing the function. 
 *
 * Return values:
 *     -1: error occurred, dynamic linking was unsuccessful
 *      0: success
 */
int FORTRAN(efcn_gather_info)( int *id_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  ExternalFunctionInternals *i_ptr=NULL;
  int i=0, j=0;
  char ef_object[1024]="", tempText[EF_MAX_NAME_LENGTH]="", *c;

  static int return_val=0; /* static because it needs to exist after the return statement */

  void *handle;
  void (*f_init_ptr)(int *);


  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return return_val; }

  /*
   * Get a handle for the shared object.
   */
  strcat(ef_object, ef_ptr->path);
  strcat(ef_object, ef_ptr->name);
  strcat(ef_object, ".so");

  /*
   * Following might need to be added to get WebFerret to work
   * Commented out because it's Solaris specific
   * JS
   */
#if 0
  if (dlopen("liballferret.so", RTLD_LAZY | RTLD_GLOBAL) == NULL){
      fprintf(stderr, "  dlerror: %s\n", dlerror());
  }
  if (dlopen(ef_object, RTLD_LAZY | RTLD_GLOBAL) == NULL){
      fprintf(stderr, "  dlerror: %s\n", dlerror());
  }

  ef_ptr->handle = dlopen(0, RTLD_LAZY);
#endif
  /*  if ( (ef_ptr->handle = dlopen(ef_object, RTLD_LAZY)) == NULL ) {*/
  /* if ( (ef_ptr->handle = dlopen(ef_object, RTLD_NOW || RTLD_GLOBAL)) == NULL ) { */
  /* kob - commented out above line, and removed RTLD_GBAL check from below on
     advice of jc - osf didn't have a definition for RTLD_GLOBAL */
  if ( (ef_ptr->handle = dlopen(ef_object, RTLD_NOW)) == NULL ) {
    fprintf(stderr, "\n\
ERROR in External Function %s:\n\
Dynamic linking call dlopen() returns --\n\
\"%s\".\n", ef_ptr->name, dlerror());
    return -1;
  }
  
  /*
   * Allocate and default initialize the internal information.
   * If anything went wrong, return the return_val.
   */
  return_val = EF_New(ef_ptr);

  if ( return_val != 0) {
    return return_val;
  }

  /*
   * Call the external function to really initialize the internal information.
   */
  i_ptr = ef_ptr->internals_ptr;

  if ( i_ptr->language == EF_C ) {

    fprintf(stderr, "\nERROR: C is not a supported language for External Functions.\n\n");
    return_val = -1;
    return return_val;

  } else if ( i_ptr->language == EF_F ) {

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGFPE.\n");
      return;
    }
    if ( (segv_handler = signal(SIGSEGV, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGSEGV.\n");
      return;
    }
    if ( (int_handler = signal(SIGINT, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGINT.\n");
      return;
    }
    if ( (bus_handler = signal(SIGBUS, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGBUS.\n");
      return;
    }
    if (sigsetjmp(sigjumpbuffer, 1) != 0) {
      /* Warning message printed by signal handler. */
      return;
    }
    canjump = 1;

    /* Information about the overall function */

    sprintf(tempText, "");
    strcat(tempText, ef_ptr->name);
    strcat(tempText, "_init_");
    f_init_ptr = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
    if (f_init_ptr == NULL) {
      fprintf(stderr, "ERROR in efcn_gather_info(): %s is not found.\n", tempText);
      fprintf(stderr, "  dlerror: %s\n", dlerror());
      return -1;
    }

    (*f_init_ptr)(id_ptr);

    /*
     * Restore the old signal handlers.
     */
    if (signal(SIGFPE, (*fpe_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGFPE handler.\n");
      return;
    }
    if (signal(SIGSEGV, (*segv_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGSEGV handler.\n");
      return;
    }
    if (signal(SIGINT, (*int_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGINT handler.\n");
      return;
    }
    if (signal(SIGBUS, (*bus_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGBUS handler.\n");
      return;
    }

  }
  
  return 0;
}


/*
 * Find an external function based on its integer ID, 
 * Query the function about custom axes. Store the context
 * list information for use by utility functions.
 */
void FORTRAN(efcn_get_custom_axes)( int *id_ptr, int *cx_list_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  char tempText[EF_MAX_NAME_LENGTH]="";

  void (*fptr)(int *);

  /*
   * Store the context list globally.
   */
  EF_store_globals(NULL, NULL, cx_list_ptr, NULL, NULL);

  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return; }

  if ( ef_ptr->internals_ptr->language == EF_F ) {

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGFPE.\n");
      return;
    }
    if ( (segv_handler = signal(SIGSEGV, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGSEGV.\n");
      return;
    }
    if ( (int_handler = signal(SIGINT, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGINT.\n");
      return;
    }
    if ( (bus_handler = signal(SIGBUS, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGBUS.\n");
      return;
    }
    if (sigsetjmp(sigjumpbuffer, 1) != 0) {
      /* Warning message printed by signal handler. */
      return;
    }
    canjump = 1;

    sprintf(tempText, "");
    strcat(tempText, ef_ptr->name);
    strcat(tempText, "_custom_axes_");

    fptr  = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
    (*fptr)( id_ptr );

    /*
     * Restore the old signal handlers.
     */
    if (signal(SIGFPE, (*fpe_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGFPE handler.\n");
      return;
    }
    if (signal(SIGSEGV, (*segv_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGSEGV handler.\n");
      return;
    }
    if (signal(SIGINT, (*int_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGINT handler.\n");
      return;
    }
    if (signal(SIGBUS, (*bus_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGBUS handler.\n");
      return;
    }

  } else {

    fprintf(stderr, "\nExternal Functions in C are not supported yet.\n\n");

  }

  return;
}


/*
 * Find an external function based on its integer ID, 
 * Query the function about abstract axes. Pass memory,
 * mr_list and cx_list info into the external function.
 */
void FORTRAN(efcn_get_result_limits)( int *id_ptr, float *memory, int *mr_list_ptr, int *cx_list_ptr )
{
  ExternalFunction *ef_ptr=NULL;
  char tempText[EF_MAX_NAME_LENGTH]="";

  void (*fptr)(int *);

  /*
   * Store the memory pointer and various lists globally.
   */
  EF_store_globals(memory, mr_list_ptr, cx_list_ptr, NULL, NULL);

  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) { return; }

  if ( ef_ptr->internals_ptr->language == EF_F ) {

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGFPE.\n");
      return;
    }
    if ( (segv_handler = signal(SIGSEGV, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGSEGV.\n");
      return;
    }
    if ( (int_handler = signal(SIGINT, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGINT.\n");
      return;
    }
    if ( (bus_handler = signal(SIGBUS, EF_signal_handler)) == SIG_ERR ) {
      fprintf(stderr, "\nERROR in efcn_gather_info() catching SIGBUS.\n");
      return;
    }
    if (sigsetjmp(sigjumpbuffer, 1) != 0) {
      /* Warning message printed by signal handler. */
      return;
    }
    canjump = 1;

    sprintf(tempText, "");
    strcat(tempText, ef_ptr->name);
    strcat(tempText, "_result_limits_");

    fptr  = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
    (*fptr)( id_ptr);

    /*
     * Restore the old signal handlers.
     */
    if (signal(SIGFPE, (*fpe_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGFPE handler.\n");
      return;
    }
    if (signal(SIGSEGV, (*segv_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGSEGV handler.\n");
      return;
    }
    if (signal(SIGINT, (*int_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGINT handler.\n");
      return;
    }
    if (signal(SIGBUS, (*bus_handler)) == SIG_ERR) {
      fprintf(stderr, "\nERROR in efcn_gather_info() restoring default SIGBUS handler.\n");
      return;
    }

  } else {

    fprintf(stderr, "\nExternal Functions in C are not supported yet.\n\n");

  }

  return;
}


/*
 * Find an external function based on its integer ID, 
 * pass the necessary information and the data and tell
 * the function to calculate the result.
 */
void FORTRAN(efcn_compute)( int *id_ptr, int *narg_ptr, int *cx_list_ptr, int *mr_list_ptr, int *mres_ptr,
	float *bad_flag_ptr, int *mr_arg_offset_ptr, float *memory, int *status )
{
  ExternalFunction *ef_ptr=NULL;
  ExternalFunctionInternals *i_ptr=NULL;
  float *arg_ptr[EF_MAX_COMPUTE_ARGS];
  int xyzt=0, i=0, j=0;
  int size=0;
  char tempText[EF_MAX_NAME_LENGTH]="";

  /*
   * Prototype all the functions needed for varying numbers of
   * arguments and work arrays.
   */

  void (*fptr)(int *);
  void (*f1arg)(int *, float *, float *);
  void (*f2arg)(int *, float *, float *, float *);
  void (*f3arg)(int *, float *, float *, float *, float *);
  void (*f4arg)(int *, float *, float *, float *, float *, float *);
  void (*f5arg)(int *, float *, float *, float *, float *, float *, float *);
  void (*f6arg)(int *, float *, float *, float *, float *, float *, float *,
		float *);
  void (*f7arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *);
  void (*f8arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *);
  void (*f9arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *);
  void (*f10arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *);
  void (*f11arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *);
  void (*f12arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *);
  void (*f13arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *);
  void (*f14arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *);
  void (*f15arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *);
  void (*f16arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *, float *);
  void (*f17arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *, float *, float *);
  void (*f18arg)(int *, float *, float *, float *, float *, float *, float *,
		float *, float *, float *, float *, float *, float *, float *, float *,
        float *, float *, float *, float *, float *);

  /*
   * Initialize the status
   */
  *status = FERR_OK;

  /*
   * Store the array dimensions for memory resident variables and for working storage.
   * Store the memory pointer and various lists globally.
   */
  FORTRAN(efcn_copy_array_dims)();
  EF_store_globals(memory, mr_list_ptr, cx_list_ptr, mres_ptr, bad_flag_ptr);

  /*
   * Find the external function.
   */
  if ( (ef_ptr = ef_ptr_from_id_ptr(id_ptr)) == NULL ) {
    fprintf(stderr, "\n\
ERROR in efcn_compute() finding external function: id = [%d]\n", *id_ptr);
    *status = FERR_EF_ERROR;
    return;
  }

  i_ptr = ef_ptr->internals_ptr;

  if ( i_ptr->language == EF_F ) {

    /*
     * Begin assigning the arg_ptrs.
     */

    /* First come the arguments to the function. */

     for (i=0; i<i_ptr->num_reqd_args; i++) {
       arg_ptr[i] = memory + mr_arg_offset_ptr[i];
     }

    /* Now for the result */

     arg_ptr[i++] = memory + mr_arg_offset_ptr[EF_MAX_ARGS];

    /* Now for the work arrays */

    /*
     * If this program has requested working storage we need to 
     * ask the function to specify the amount of space needed
     * and then create the memory here.  Memory will be released
     * after the external function returns.
     */
    if (i_ptr->num_work_arrays > EF_MAX_WORK_ARRAYS) {

	  fprintf(stderr, "\n\
ERROR specifying number of work arrays in ~_init subroutine of external function %s\n\
\tnum_work_arrays[=%d] exceeds maximum[=%d].\n\n", ef_ptr->name, i_ptr->num_work_arrays, EF_MAX_WORK_ARRAYS);
	  *status = FERR_EF_ERROR;
	  return;

    } else if (i_ptr->num_work_arrays < 0) {

	  fprintf(stderr, "\n\
ERROR specifying number of work arrays in ~_init subroutine of external function %s\n\
\tnum_work_arrays[=%d] must be a positive number.\n\n", ef_ptr->name, i_ptr->num_work_arrays);
	  *status = FERR_EF_ERROR;
	  return;

    } else if (i_ptr->num_work_arrays > 0)  {

      sprintf(tempText, "");
      strcat(tempText, ef_ptr->name);
      strcat(tempText, "_work_size_");

      fptr = (void (*)(int *))dlsym(ef_ptr->handle, tempText);
      if (fptr == NULL) {
	fprintf(stderr, "\n\
ERROR in efcn_compute() accessing %s\n", tempText);
	*status = FERR_EF_ERROR;
        return;
      }
      (*fptr)( id_ptr );


	  /* Allocate memory for each individual work array */

      for (j=0; j<i_ptr->num_work_arrays; i++, j++) {

        int iarray,xlo,ylo,zlo,tlo,xhi,yhi,zhi,thi;
        iarray = j+1;
        xlo = i_ptr->work_array_lo[j][0];
        ylo = i_ptr->work_array_lo[j][1];
        zlo = i_ptr->work_array_lo[j][2];
        tlo = i_ptr->work_array_lo[j][3];
        xhi = i_ptr->work_array_hi[j][0];
        yhi = i_ptr->work_array_hi[j][1];
        zhi = i_ptr->work_array_hi[j][2];
        thi = i_ptr->work_array_hi[j][3];

        FORTRAN(efcn_set_work_array_dims)(&iarray,&xlo,&ylo,&zlo,&tlo,&xhi,&yhi,&zhi,&thi);

        size = sizeof(float) * (xhi-xlo+1) * (yhi-ylo+1) * (zhi-zlo+1) * (thi-tlo+1);

        if ( (arg_ptr[i] = (float *)malloc(size)) == NULL ) { 
          fprintf(stderr, "\n\
ERROR in efcn_compute() allocating %d bytes of memory\n\
      work array %d:  X=%d:%d, Y=%d:%d, Z=%d:%d, T=%d:%d\n", 
      iarray,xlo,xhi,ylo,yhi,zlo,zhi,tlo,thi,size);
	  *status = FERR_EF_ERROR;
	  return;
        }
      }

    }

    /*
     * Prepare for bailout possibilities by setting a signal handler for
     * SIGFPE, SIGSEGV, SIGINT and SIGBUS and then by cacheing the stack 
     * environment with sigsetjmp (for the signal handler) and setjmp 
     * (for the "bail out" utility function).
     */   
    if ( (fpe_handler = signal(SIGFPE, EF_signal_handler)) == SIG_ERR ) {
{'fraction_non_alphanumeric': 0.137526043107104, 'fraction_numerical': 0.00413002194074156, 'mean_word_length': 3.194740912606342, 'pattern_counts': {'":': 0, '<': 33, '<?xml version=': 0, '>': 115, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5752176', 'n_tokens_mistral': 18560, 'n_tokens_neox': 17817, 'n_words': 5206}