/*************************************************************************
 *                  
 *       (c) Copyright 1992,1993,1994 by G & A Technical Software, Inc.,
 *             28 Research Drive, Hampton, Virginia, 23666.
 *
 *   All Rights Reserved. No part of this software or publication may be
 *   reproduced, stored in a retrieval system, or transmitted, in any form
 *   or by any means, electronic, mechanical, photocopying, recording, or
 *   otherwise without the prior written permission of G & A Technical
 *   Software, Inc.
 *  
 *************************************************************************
 *
 * Filename: s3_callcr.c
 *
 * Purpose:  Provides S3 calling mechanism for C subroutines and functions.
 *
 * Author:   John Burton
 *
 * Date:     5/31/94
 *
 *************************************************************************
 *
 * Modification History:
 *
 * $Log: s3_callfr.c,v $
 * Revision 2.1  1994/07/08  18:07:38  jcburt
 * No changes since last commit. Just bringing everything up to the same
 * revision number
 *
 * Revision 2.0.0.1  1994/06/28  18:48:27  jcburt
 * S3 Version 2.0 Initial Source
 *
 *
 *************************************************************************
 *
 * Revision Control Information:
 */
   static char rcsid[]  = "$Id: s3_callfr.c,v 2.1 1994/07/08 18:07:38 jcburt Exp $";
   static char rcsrev[] = "$Revision: 2.1 $";

/****************************************************************************/
/*  Written by:                                                             */
/*    John Burton                                                           */
/*    jcburt@gatsibm.larc.nasa.gov                                          */
/*  Date:                                                                   */
/*    02/20/92                                                              */
/****************************************************************************/
/*  Routines and Revision history:                                          */
/*                                                                          */
/*    #define kill_trailing                                                 */
/*      - 10/20/91 Original version created                 (John Burton)   */
/*                                                                          */
/*    (char *)kill_trailingn                                                */
/*      - 10/20/91 Original version created                 (John Burton)   */
/*                                                                          */
/*    int call_f_function                                                   */
/*      - 10/20/91 Original version created                 (John Burton)   */
/*      - 01/30/92 Added dataset bounds violation checking  (John Burton)   */
/*                                                                          */
/*    void call_f_subroutine                                                */
/*      - 10/20/91 Original version created                 (John Burton)   */
/*      - 01/30/92 Added dataset bounds violation checking  (John Burton)   */
/*                                                                          */
/****************************************************************************/

/*************************************************************************
 * 
 * Include Files
 *
 *************************************************************************/


#include "s3_defines.h"
#include "s3_typedefs.h"
#include "s3_externals.h"
#include "s3_globals.h"

#include <time.h>

/*************************************************************************
 * 
 * Defines and Macros
 *
 *************************************************************************/

/* kill the trailing char t's in string s. */
#define kill_trailing(s,t) kill_trailingn((s),(t),(s)+strlen(s))


/*************************************************************************
 *
 * Module:      kill_trailingn
 *
 * Description: Will kill specified trailing characters in a string.
 *              
 * Syntax:      char *kill_trailingn(char *s, char t, char *e)
 *
 * Inputs:      *s:  A pointer to the string to be modified
 *               t:  The character to be killed
 *              *e:  Pointer to the end of the string to be modified.
 *                   e may actually point to anywhere in s. s's new
 *                   NULLS will be placed at e or earlier in order to 
 *                   remove any trailing t's. If e < s string s is left
 *                   unchanged.
 * 
 * Outputs:     None
 *
 * Returns:     The modified string.
 *
 * Modules Called: 
 *
 *************************************************************************/


static char *kill_trailingn(char *s, char t, char *e)
{ 
  if (e==s) *e = '\0';                 /* Kill the string makes sense here.*/
  else if (e>s) {                      /* Watch out for neg. length string.*/
    while (e>s && *--e==t);            /* Don't follow t's past beginning. */
    e[*e==t?0:1] = '\0';               /* Handle s[0]=t correctly.       */
  }
  return s;
}

/*************************************************************************
 *
 * Module:      vkill_trailing
 *
 * Description: Will kill specified trailing characters in a vector of
 *              strings.
 *              
 * Syntax:      char *vkill_trailing(char *cstr, int elem_len,
 *                                   int sizeofcstr, char t)
 *
 * Inputs:      *cstr:       A pointer to the vector of strings to 
 *                           be modified
 *               elem_len:   Length of the individual string
 *               sizeofcstr: Size of the vector of strings
 *               t:          The Character to be killed
 * 
 * Outputs:     None
 *
 * Returns:     The modified vector of strings.
 *
 * Modules Called: kill_trailingn
 *
 *************************************************************************/

/* Note the following assumes that any element which has t's to be chopped off,
does indeed fill the entire element. */

static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
{
  int i;
  for (i=0; i<sizeofcstr/elem_len; i++) /* elem_len includes \0 for C strings. */
    kill_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
  return cstr;
}



/*************************************************************************
 *
 * Module:      c2fstrv
 *
 * Description: Convert a vector of C strings into FORTRAN strings.
 *              
 * Syntax:      char *c2fstrv(char *cstr, char *fstr, int elem_len,
 *                            int sizeofcstr)
 *
 * Inputs:      *cstr:       A pointer to the vector of C strings 
 *              *fstr:       A pointer to the vector of FORTRAN strings
 *               elem_len:   Length of the individual string
 *               sizeofcstr: Size of the vector of strings
 * 
 * Outputs:     None
 *
 * Returns:     The vector of FORTRAN strings
 *
 * Modules Called: 
 *
 *************************************************************************/

static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
{ 
  int i,j;

  for (i=0; i<sizeofcstr/elem_len; i++) {
    for (j=1; j<elem_len && *cstr; j++) *fstr++ = *cstr++;
    cstr += 1+elem_len-j;
    for (; j<elem_len; j++) *fstr++ = ' ';
  }
  return fstr-sizeofcstr+sizeofcstr/elem_len;
}


/*************************************************************************
 *
 * Module:      f2cstrv
 *
 * Description: Convert a vector of FORTRAN strings into C strings.
 *              
 * Syntax:      char *c2fstrv(char *fstr, char *cstr, int elem_len,
 *                            int sizeofcstr)
 *
 * Inputs:      *fstr:       A pointer to the vector of FORTRAN strings 
 *              *cstr:       A pointer to the vector of C strings
 *               elem_len:   Length of the individual string
 *               sizeofcstr: Size of the vector of strings
 * 
 * Outputs:     None
 *
 * Returns:     The vector of C strings.
 *
 * Modules Called: 
 *
 *************************************************************************/

static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
{ 
  int i,j;

  cstr += sizeofcstr;
  fstr += sizeofcstr - sizeofcstr/elem_len;
  for (i=0; i<sizeofcstr/elem_len; i++) {
    *--cstr = '\0';
    for (j=1; j<elem_len; j++) *--cstr = *--fstr;
  }
  return cstr;
}


/*************************************************************************
 *
 * Module:      s3_call_f_function
 *
 * Description: Steps through the list of nds datasets and coverts the
 *              strings to the proper form as needed. Passes information 
 *              to s3_call_function to actually call the function.
 *
 * Syntax:      int s3_call_c_function(int (*func)(), int nds, DataSet **dl)
 *
 * Inputs:      *func:  A pointer to the integer function to be called.
 *                nds:  Number of datasets to be passed to "func".
 *              **dl:   An array of pointers to the datasets to be passed
 *                      to "func".
 * 
 * Outputs:     None
 *
 * Returns:     An integer value corresponding to the value returned by
 *              "func".
 *
 * Modules Called: c2fstrv, f2cstrv, kill_trailing, vkill_trailing,
 *                 s3_call_function, s3_check_bounds
 *
 *************************************************************************/

int s3_call_f_function(int (*func)(), int nds, DataSet **dl)
{
  int    i,j,quit;
  char  *a[MAXARGS];

  quit = FALSE;
  j = nds;
  if(bounds)
    for(i=0;i<nds;i++)
      s3_check_bounds(dl[i],"Before Call");
  for(i=0;i<nds;i++)
    {
      switch(dl[i]->type)
	{
	case STRING :
	  switch(dl[i]->NDIMS)
	  {
	  case 0 :
	    a[i] = dl[i]->d.ch;
	    break;
	  case 1 :
	    a[i] = dl[i]->d.ch;
	    a[j++] = (char *)(dl[i]->dimlist[0]->co.value);
	    break;
	  case 2 :
	    a[i] = c2fstrv(dl[i]->d.ch,dl[i]->d.ch,
			   dl[i]->dimlist[1]->co.value,(dl[i]->dimlist[0]->co.value*dl[i]->dimlist[1]->co.value));
	    a[j++] = (char *)(dl[i]->dimlist[0]->co.value);
	    break;
	  }
	  break;
	case CHAR:
	  s3_dprint("dl[%d]->dimlist[0]->co.value = %d",i,dl[i]->dimlist[0]->co.value);
	  a[i] = dl[i]->d.ch;
	  a[j++] = (char *)(dl[i]->dimlist[0]->co.value);
	  break;
	default:
	  a[i] = dl[i]->d.ch;
	}
    }
  quit = s3_call_function(func,a,j);
  for(i=0;i<nds;i++)
    {
      if(dl[i]->type == STRING)
	switch(dl[i]->NDIMS)
	  {
	  case 0 :
	    break;
	  case 1 :
	    kill_trailing(dl[i]->d.ch,' ');
	    break;
	  case 2 :
	    vkill_trailing(f2cstrv(dl[i]->d.ch,dl[i]->d.ch,
				   dl[i]->dimlist[1]->co.value,(dl[i]->dimlist[0]->co.value*dl[i]->dimlist[1]->co.value)),
			   dl[i]->dimlist[1]->co.value,(dl[i]->dimlist[0]->co.value*dl[i]->dimlist[1]->co.value),' ');
	    break;
	  }
    }
  if(bounds)
    for(i=0;i<nds;i++)
      s3_check_bounds(dl[i],"After Call");
  return quit;
}





/*************************************************************************
 *
 * Module:      s3_call_f_subroutine
 *
 * Description: Steps through the list of nds datasets and coverts the
 *              strings to the proper form as needed. Passes information 
 *              to s3_call_function to actually call the function.
 *
 * Syntax:      int s3_call_f_function(int (*func)(), int nds, DataSet **dl)
 *
 * Inputs:      *func: A pointer to the integer function to be called.
 *              nds:   Number of datasets to be passed to "func".
 *              **dl:  An array of pointers to the datasets to be passed
 *                     to "func".
 * 
 * Outputs:     None
 *
 * Returns:     None
 *
 * Modules Called: c2fstrv, f2cstrv, kill_trailing, vkill_trailing,
 *                 s3_call_subroutine, s3_check_bounds
 *
 *************************************************************************/
/*      - Performs the same operations as call_f_function except no value   */
/*        is returned                                                       */

void s3_call_f_subroutine(int (*func)(), int nds, DataSet **dl)
{
  int    i,j,quit;
  char  *a[MAXARGS];
	
  j = nds;
  if(bounds)
    for(i=0;i<nds;i++)
      s3_check_bounds(dl[i],"Before Call");

  for(i=0;i<nds;i++)
    {
      switch(dl[i]->type)
	{
	case STRING :
	  switch(dl[i]->NDIMS)
	  {
	  case 0 :
	    a[i] = dl[i]->d.ch;
	    break;
	  case 1 :
	    a[i] = dl[i]->d.ch;
	    a[j++] = (char *)(dl[i]->dimlist[0]->co.value);
	    break;
	  case 2 :
	    a[i] = c2fstrv(dl[i]->d.ch,dl[i]->d.ch,
				dl[i]->dimlist[1]->co.value,(dl[i]->dimlist[0]->co.value*dl[i]->dimlist[1]->co.value));
	    a[j++] = (char *)(dl[i]->dimlist[0]->co.value);
	    break;
	  }
	  break;
	case CHAR:
	  s3_dprint("dl[%d]->dimlist[0]->co.value = %d",i,dl[i]->dimlist[0]->co.value);
	  a[i] = dl[i]->d.ch;
	  a[j++] = (char *)(dl[i]->dimlist[0]->co.value);
	  break;
	default:
	  a[i] = dl[i]->d.ch;
	}
    }
  s3_call_subroutine(func,a,j);
  for(i=0;i<nds;i++)
    {
      if(dl[i]->type == STRING)
	switch(dl[i]->NDIMS)
	  {
	  case 0 :
	    break;
	  case 1 :
	    kill_trailing(dl[i]->d.ch,' ');
	    break;
	  case 2 :
	    vkill_trailing(f2cstrv(dl[i]->d.ch,dl[i]->d.ch,
				   dl[i]->dimlist[1]->co.value,(dl[i]->dimlist[0]->co.value*dl[i]->dimlist[1]->co.value)),
			   dl[i]->dimlist[1]->co.value,(dl[i]->dimlist[0]->co.value*dl[i]->dimlist[1]->co.value),' ');
	    break;
	  }
    }
  if(bounds)
    for(i=0;i<nds;i++)
      s3_check_bounds(dl[i],"After Call");
}