/***************************** LICENSE START ***********************************

 Copyright 2012 ECMWF and INPE. This software is distributed under the terms
 of the Apache License version 2.0. In applying this license, ECMWF does not
 waive the privileges and immunities granted to it by virtue of its status as
 an Intergovernmental Organization or submit itself to any jurisdiction.

 ***************************** LICENSE END *************************************/

#include "mars.h"

/* macro_api.h has no dependencies on mars.h */
#include "macro_api.h"

/* macro_api_internals.h hides Mars dependancies, it includes mars.h */
#include "macro_api_internals.h"

/*=====================================

 Mars to external routines communication

 This file contains the implementation for:
 - the original Fortran interface routines ('MGET*'/'MSET*')
 - the second generation Fortran interface routines ('mfi_*')
   - except two routines implemented in file macro_api_f90.f90
   - internal Fortran interface routines ('mifi_*')
 - C/C++ interface functions ('mci_*')

=====================================*/

/* int mgetg_C( gribarg** g, int* c ); */

#ifdef FORTRAN_UPPERCASE
#define marscnt_ MARSCNT
#define marsarg_ MARSARG
#define marsret_ MARSRET
#define marsend_ MARSEND
#define marsout_ MARSOUT
#define gribnew_ GRIBNEW
#define gribcnt_ GRIBCNT
#define gribcopy_ GRIBCOPY
#define gribdata_ GRIBDATA
#define gribfile_ GRIBFILE
#define gribfree_ GRIBFREE
#define gribnext_ GRIBNEXT
#define gribsave_ GRIBSAVE
#define mfail_ MFAIL
#define mgetb_ MGETB
#define mgetg_ MGETG
#define mgeti_ MGETI
#define mgetm_ MGETM
#define mgetn2_ MGETN2
#define mgetn_ MGETN
#define mgets_ MGETS
#define mgetv_ MGETV
#define msetb_ MSETB
#define msetg_ MSETG
#define mseti_ MSETI
#define msetm_ MSETM
#define msetn2_ MSETN2
#define msetn_ MSETN
#define msets_ MSETS
#define msetv_ MSETV
#define mloadb_ MLOADB
#define mloadg_ MLOADG
#define mnewb_ MNEWB
#define mnewg_ MNEWG
#define mrewg_ MREWG
#endif


static int       argc = 0;
static int       argn = 0;
static arg*      args = NULL;
static boolean sFirst = true;
static char*    sName = NULL;
static char*    sFile = NULL;


/* To avoid sending pointers back to the user program, we maintain a list of all
   gribarg pointers generated here and return indexes into our list instead.
*/

static fortint num_gribargs = 0;
static void **gribargs = NULL;



static fortint add_new_gribarg_pointer (void *new_gribarg_ptr)
{
    num_gribargs++;
    gribargs = realloc (gribargs, num_gribargs * sizeof(void *));
    gribargs[num_gribargs-1] = new_gribarg_ptr;
    return num_gribargs-1;
}

static void *get_gribarg_ptr_from_index (int index)
{
    return gribargs[index];
}


static fortint get_gribarg_index_from_ptr (void *ptr)
{
    fortint i;
    
    for (i = 0 ; i < num_gribargs; i++)
    {
        if (gribargs[i] == ptr)
            return i;
    }
    
    marslog(LOG_EXIT,"get_gribarg_index_from_ptr: pointer not found in list of %d pointers.", num_gribargs);
    return 0;
}



static void mout(int lvl,char *msg)
{
}

static void the_end(int code,void *data)
{
	printf("end is %d\n",code);
}

static void minit(void)
{
	int      ac;
	char    *av;
	request *r,*s;
	int     i;

	if(!sFirst)
	   return;

	sFirst = false;

	sFile = getenv("MREQUEST");
	sName = getenv("MNAME");

	ac = 1;
	av = strcache(sName?sName:"external");

	marsinit(&ac,&av,0,0,0);

	if(!sFile)
	   marslog(LOG_EXIT,"Mars/Metview external environment not set");

	/* mars.outproc = mout; */

	s = r = read_request_file(sFile);
	while(s) {
		s = s->next;
		argc++;
	}

	/* empty file */
	fclose(fopen(sFile,"w"));

	if(argc == 0)
	   return;

	args = NEW_ARRAY(arg,argc);
	i = 0;

	while(r)
	{
		const char *t = r->name;
		const char *v = get_value(r,"VALUE",0);

		if(t == NULL)
			marslog(LOG_EXIT,"No data type");
		else if( EQ(t,"NUMBER"))
		{
			args[i].kind = 'N';
			args[i].u.dval = v?atof(v):0.0;
		}
		else if( EQ(t,"STRING") )
		{
			args[i].kind = 'S';
			args[i].u.sval = strcache(v?v:"");
		}
		else if( EQ(t,"GRIB") )
		{
			args[i].kind = 'G';
			args[i].u.rval = r;
		}
		else if( EQ(t,"BUFR") )
		{
			args[i].kind = 'B';
			args[i].u.rval = r;
		}
		else if( EQ(t,"IMAGE") )
		{
			args[i].kind = 'I';
			args[i].u.rval = r;
		}
		else if( EQ(t,"VECTOR") )
		{
			args[i].kind = 'V';
			args[i].u.rval = r;
		}
		else marslog(LOG_EXIT,"Unsupported type %s",t);

		r = r->next;
		i++;
	}

	/* install_exit_proc(the_end,NULL); */

}

static void mcheck(fortint *n,char kind, char *name)
{
	minit();

	if(*n == 0)
	   *n = argn+1;

	if(*n < 1 || *n > argc)
		marslog(LOG_EXIT,"Parameter %d is is out of range."
		    " Only %d parameters where passed",*n,argc);
	if(args[*n-1].kind != kind)
		marslog(LOG_EXIT,"Parameter %d is not of type %s",*n,name);

	argn = *n;
}


/* read_vector_from_request 
     Reads the given request and reads in the associated vector file.
     Memory is allocated here for the vector, so it is then the responsibility
     of the called to handle it.
     Returns 0 if ok, 1 on error.
*/
int read_vector_from_request( request *r, double** vec, int* length )
{
   int size, i;
   const char *c;
   const char *path;
   double *v;
   char buf[20] = "";
   FILE *f;
   int read;

   path = get_value( r, "PATH", 0 );     /* get the path to the storage file */

   f = fopen(path, "r");
   
   if (!f)
   {
      marslog( LOG_EXIT, "read_vector_from_request: unable to load file %s", path);
   }
   else
   {
      fread (buf, sizeof(char), 14, f);
      buf[14] = '\0';

      if (strcmp(buf, "METVIEW_VECTOR"))
      {
         marslog (LOG_EXIT, "read_vector_from_request: start of vector file should be METVIEW_VECTOR. Is: %s", buf);
      }

      fread (buf, sizeof(char), 10, f); /* read the data type */
      buf[10] = '\0';
      if (strncmp(buf, "float64", 7)) /* we only allow this for now */
      {
         marslog (LOG_EXIT, "read_vector_from_request: only allow float64 values just now. Is: '%s'", buf);
      }


      read = fread (&size, sizeof(int),    1,    f);  /* read the number of values */


      /*-- vector to be returned, must be free'd by the calling pgm --*/
      v = malloc( size*sizeof(double) );
      if( !v )
      {
          marslog( LOG_EXIT
              ,"read_vector_from_request: unable to get memory for %d elements"
              ,size );
      }

      read = fread (v, sizeof(double), size, f);  /* read the values */

      if (read != size)
      {
          marslog (LOG_EXIT, "read_vector_from_request: tried to write %d elements - managed %d.", size, read);
      }

     *vec    = v;
     *length = size;
    }
    return 0;
}



int write_vector_to_file(FILE *f, int size, double *values)
{
	size_t written;

	fprintf (f, "METVIEW_VECTOR");
	fprintf (f, "float64   "); /* hard-coded for now */
	written = fwrite (&size,   sizeof(int),    1,    f);  /* write the number of values */
	written = fwrite (values,  sizeof(double), size, f);  /* write the values */
	fprintf (f, "METVIEW_VECTOR_END");

	if (written != size)
	{
		marslog(LOG_EXIT, "Tried to write %d elements - managed %d.", size, written);
	}

	return ferror(f);
}





static void getn(fortint n,double *d)
{
	mcheck(&n,'N',"number");
	*d = args[n-1].u.dval;
}

void mgetn_(fortfloat *f)
{
	double d;
	getn(0,&d);
	*f = d;
}

void mgetn2_(double *d)
{
	getn(0,d);
}

void mgetv_(fortint *s, fortfloat *v)
{
   fortint n = 0;
   int i, length;
   fortint size;
   request* r;
   double *vec;

   mcheck( &n, 'V', "vector" );         /* ensure that next is a vector */
   r = args[n-1].u.rval;

   read_vector_from_request(r, &vec, &length);
   size = (fortint) length;


   if (size > *s)
   {
       marslog( LOG_EROR
               , "MGETV: Fortran array too small, only %d first vector values returned"
               , *s );
       size = *s;
   }

   /* convert to fortfloat */
   for (i=0; i<size; ++i)
   {
      v[i] = (fortfloat)vec[i];
   }


   /* we are responsible for freeing the memory allocated by read_vector_from_request(). */
   
   if (vec)
     free (vec);

  *s = size;
}

void mgets_(char *s,fortint l_s)
{
	fortint n = 0;
	char *p;
	mcheck(&n,'S',"string");
	p = args[n-1].u.sval;
	n = strlen(p);
	memset(s,' ',l_s);

	if(n > l_s)
	{
		marslog(LOG_EROR,"MGETS, string too small %d>%d",
		    n,l_s);
		n = l_s;
	}

	strncpy(s,p,n);
}


static fieldset *getg(fortint n)
{
	mcheck(&n,'G',"fieldset");
	/*-- we have to process one request at a time in case mgetg is called */
	/*-- more than once (in case there are several fieldset parameters)   */
	return request_to_fieldset( clone_one_request(args[n-1].u.rval) );
}


static int mgetg_C( gribarg** g, int* c)
{
	fieldset *v = getg(0);
	if(!v)
	    return 1;

	*g = NEW_CLEAR(gribarg);
	*c = v->count;
	(*g)->v = v;
	return 0;
}

void mgetg_(fortint* g,fortint* c)
{
	fortint newga;
	gribarg* gc;
	int err = mgetg_C( &gc, (int*)c );
	if( err )
	    marslog(LOG_EXIT,"MGETG, Cannot load grib file");

    newga = add_new_gribarg_pointer(gc);
	*g = newga;
}

static fieldset *geti(fortint n)
{
	mcheck(&n,'I',"image");
	return request_to_fieldset(args[n-1].u.rval);
}


void mfail_(char *msg,fortint l_msg);

void mnewb_()  {
	mfail_("MNEWB is not yet implemeted",0);
}
void mgetb_()  {
	mfail_("MGETB is not yet implemeted",0);
}
void msetb_()  {
	mfail_("MSETB is not yet implemeted",0);
}
void mloadb_() {
	mfail_("MLOADB is not yet implemeted",0);
}
void msaveb_() {
	mfail_("MSAVEB is not yet implemeted",0);
}
void mgetm_()  {
	mfail_("MGETM is not yet implemeted",0);
}
void msetm_()  {
	mfail_("MSETM is not yet implemeted",0);
}

void mgeti_(fortint *g,fortint  *c)
{
	fortint newga;
	fieldset *v = geti(0);
	gribarg  *a = NEW_CLEAR(gribarg);
	if(!v)
	   marslog(LOG_EXIT,"MGETI, Cannot load image file");

	*c = v->count;
	a->v = v;
	newga = add_new_gribarg_pointer(a);
	*g = newga;
}

void mloadg_(fortint *g,char *p,fortint *c)
{
	gribarg  *a = (gribarg*)(get_gribarg_ptr_from_index(*g));
	fieldset *v = a->v;
	int i = a->cnt++;
	long int msg_len = (*c)*sizeof(fortint);

	minit();

	if(i < 0 || i >= v->count)
		marslog(LOG_EXIT,"MLOADG, No more fields");


	if( (*c)*sizeof(fortint) < v->fields[i]->length)
		marslog(LOG_EXIT,"MLOADG, Buffer too small %d words (should be %d words)",
		    *c, (v->fields[i]->length + (sizeof(fortint) - 1) )/ sizeof(fortint));

	if(a->f == NULL || a->file != v->fields[i]->file->fname)
	{
		if(a->f)
		   fclose(a->f);
		strfree(a->file);
		a->file = strcache(v->fields[i]->file->fname);
		a->f = fopen(a->file,"r");
		if(a->f == NULL)
			marslog(LOG_EXIT|LOG_PERR,"MLOADG, cannot open %s",a->file);
	}

	if(fseek(a->f,v->fields[i]->offset,0) < 0)
		marslog(LOG_EXIT|LOG_PERR,"MLOADG, cannot position to grib");

	if(_readany(a->f,p,&msg_len))
		marslog(LOG_EXIT|LOG_PERR,"MLOADG, cannot read grib");

	v->fields[i]->length = msg_len;
}

void mnewg_(fortint *g)
{
	fortint newga;
	gribarg  *a ;
	minit();
	a = NEW_CLEAR(gribarg);
	newga = add_new_gribarg_pointer(a);
	*g = newga;
}

void mrewg_(fortint *g)  /*-- mrewg: rewind fieldset (warning: no checks done!) --*/
{
	gribarg *a  = (gribarg*)(get_gribarg_ptr_from_index(*g));
	a->cnt = 0;
}

/* here *c gives the length of GRIB msg in Fortran integers */
void msaveg_(fortint *g,char *p,fortint *c)
{
	fortint c2bytes = (*c )* sizeof(fortint);
	msavebyteg_( g, p, &c2bytes );
}

/* here *c gives the length of GRIB msg in bytes (chars) */
void msavebyteg_(fortint *g,char *p,fortint *c)
{
	gribarg *a  = (gribarg*)(get_gribarg_ptr_from_index(*g));
	fortint j,length, pad;
	char x;
	minit();

	if(a->f == NULL)
	{
		a->file = strcache(marstmp());
		a->f = fopen(a->file,"w");
		if(a->f == NULL)
			marslog(LOG_EXIT|LOG_PERR,"MSAVEG: Cannot open %s",a->file);
	}

	length = *c;
	pad    = ((length + 119)/120) * 120 - length;

	if(fwrite(p,1,length,a->f) != length)
		marslog(LOG_EXIT|LOG_PERR,"MSAVEG: Error while writing to disk");

	x = 0;
	for(j=0;j<pad;j++)
		if(fwrite(&x,1,1,a->f) != 1)
			marslog(LOG_EXIT|LOG_PERR,"MSAVEG: Error while writing to disk");

}

void msetg_(fortint *g)
{
	gribarg *a = (gribarg*)(get_gribarg_ptr_from_index(*g));
	FILE *f ;

	minit();

	if(a->f)
	   fclose(a->f);
	a->f = NULL;

	f = fopen(sFile,"a+");
	fprintf(f,"GRIB,TEMPORARY=1,PATH='%s'\n",
	    a->file);
	fclose(f);

}

void mseti_(fortint *g)
{
	gribarg *a = (gribarg*)(get_gribarg_ptr_from_index(*g));
	FILE *f ;

	minit();

	if(a->f)
	   fclose(a->f);
	a->f = NULL;

	f = fopen(sFile,"a+");
	fprintf(f,"IMAGE,TEMPORARY=1,PATH='%s'\n",
	    a->file);
	fclose(f);
}

void msets_(char *s,fortint l_s)
{
	FILE *f;
	int space = 0;
	minit();
	f = fopen(sFile,"a+");
	fprintf(f,"STRING,VALUE=\"");

	space = 0;

	while(*s && l_s--)
	{
		if(*s == '"' || *s == '\\')
		   fputc('\\',f);
		if(*s == ' ')
		   space++;
		else
		{
			while(space-->0) fputc(' ',f);
			fputc(*s,f);
		}
		s++;
	}
	fprintf(f,"\"\n");
	fclose(f);
}

void msetn2_(double *d)
{
	FILE *f;
	minit();
	f = fopen(sFile,"a+");
	fprintf(f,"NUMBER,VALUE=%g\n",*d);
	fclose(f);
}

void msetn_(fortfloat *f)
{
	double d = *f;
	msetn2_(&d);
}

void msetv_(fortint* s, fortfloat* v)
{
  FILE *f;
  fortint i;

  minit();

  f = fopen(sFile,"a+");

  fprintf(f,"VECTOR,SIZE=%d,VALUES=", *s);
  if( *s > 0 )
    {
      for( i=0; i<*s; ++i )
	{
	  fprintf( f, "%g", (double)v[i] );
	  if( (i+1) < *s )
	    fprintf( f, "/" );
	}
    }
  else
    {
      fprintf( f, "0" );
    }
  fprintf( f, "\n" );

  fclose(f);
}

void mfail_(char *msg,fortint l_msg)
{
	char buf[512];                  /* no '\0' in Fortran strings! */
	size_t len = l_msg < 512 ? l_msg : 511;
	strncpy( buf, msg, len );
	buf[ len ] = '\0';              /* make sure we have terminating null */

	minit();

	marslog(LOG_EXIT,"%s",buf);
}

void margs_(fortint *cnt,char *types,fortint l_types)
{
	int i,n;

	minit();
	*cnt = argc;

	memset(types,0,l_types);
	n = argc;

	if(n > l_types)
	{
		marslog(LOG_EROR,"MARGS, string to small %d>%d",
		    n,l_types);
		n = l_types;
	}

	for(i=0;i<n;i++)
		types[i] = args[i].kind;
}


/* Versions with no underscore */
void mgetn(fortfloat *f) { mgetn_(f); }
void mgetn2(double *d) { mgetn2_(d); }
void msetn2(double *d) { msetn2_(d); }
void msetn(fortfloat *f) { msetn_(f); }

void mgets(char *s, fortint l_s) { mgets_(s,l_s); }
void msets(char *s, fortint l_s) { msets_(s,l_s); }

void mgetg(fortint *g, fortint *c) { mgetg_(g,c); }
void mloadg(fortint *g, char *p, fortint *c) { mloadg_(g,p,c); }
void mnewg(fortint *g) { mnewg_(g); }
void mrewg(fortint *g) { mrewg_(g); }
void msaveg(fortint *g, char *p, fortint *c) { msaveg_(g,p,c); }
void msavebyteg(fortint *g, char *p, fortint *c) { msavebyteg_(g,p,c); }
void msetg(fortint *g) { msetg_(g); }

void mgetv(fortint *s, fortfloat *v) { mgetv_(s,v); }
void msetv(fortint* s, fortfloat* v) { msetv_(s,v); }

void mgeti(fortint *g, fortint *c) { mgeti_(g,c); }
void mseti(fortint *g) { mseti_(g); }

void mfail(char *msg, fortint l_msg) { mfail_(msg,l_msg); }

void margs(fortint *cnt, char *types, fortint l_types) { margs_(cnt,types,l_types); }

void mnewb(void) { mnewb_(); }
void mgetb(void) { mgetb_(); }
void msetb(void) { msetb_(); }
void mloadb(void) { mloadb_(); }
void msaveb(void) { msaveb_(); }

void mgetm(void) { mgetm_(); }
void msetm(void) { msetm_(); }


/*=====================================

 Macro to external C/C++ routines communication: 'mci_*'

=====================================*/


double
mci_get_number()
{
   double d;
   mgetn2_( &d );
   return d;
}
void
mci_return_number( double d )
{
   msetn2_( &d );
}

/*----------------------------------------------------------==
**
**  WARNING: Memory for the string is reused for each call to this function!!!
*/
const char*
mci_get_string()
{
   static char* strbuf = 0;
   static int  sbuflen = 0;
   fortint  n = 0;
   char *p;

   mcheck( &n, 'S', "string" );
   p = args[n-1].u.sval;
   n = strlen(p);

   if( (n+1) > sbuflen )
   {
     free( strbuf );
     sbuflen = n+1;
     strbuf = (char*)malloc(sbuflen);
   }

   strcpy( strbuf, p );

   return strbuf;
}
void
mci_return_string( const char* s )
{
   msets_( (char*)s, strlen(s) );
}

/*----------------------------------------------------------==
**
**  NOTE: Memory for the vector is allocated here,
**        but freeing it is up to the calling pgm!!!
*/
void
mci_get_vector( double** vec, int* length )
{
   fortint n = 0;
   int size, i;
   request* r;
   const char *c;
   const char *path;
   double *v;
   FILE *f;
   char buf[20] = "";
   int read;

   mcheck( &n, 'V', "vector" );         /* ensure that next is a vector */
   r = args[n-1].u.rval;

   read_vector_from_request(r, vec, length);
}

void
mci_return_vector( double* vec, int length )
{
   FILE *f;
   int   i;
   char *path;
   FILE *fv;

   minit();

   f = fopen( sFile, "a+" );            /* append to the return request file */

   path = marstmp();
   fv = fopen (path, "w");
		
   if (fv)
   {
      write_vector_to_file (fv, length, vec);
      fprintf(f,"VECTOR,TEMPORARY=1,PATH='%s'\n", path);
   }

   fprintf( f, "\n" );

   fclose(f);                           /* close the return request file */
}

/*----------------------------------------------------------==
**
**  NOTE: Memory for the fieldset ptr is allocated here,
**        but freeing it is up to the calling pgm!!!
*/
void*
mci_get_fieldset( int* field_count )
{
   fortint newga;
   gribarg* ga = (gribarg*)malloc( sizeof(gribarg) );
   if( mgetg_C( &ga, field_count ) != 0 )
   {
     field_count = 0;
     marslog( LOG_EROR, "mci_get_fieldset: next parameter is not a fieldset!" );
     return NULL;
   }

   newga = add_new_gribarg_pointer(ga);

   return (void*)ga;
}

#ifdef MV_ALLOW_DEPRECATED_MCI_NAMES
void*
mci_get_grib_id_ptr( int* field_count )
{
   marslog( LOG_WARN, "'mci_get_grib_id_ptr' is deprecated, use 'mci_get_fieldset'" );
   return mci_get_fieldset( field_count );
}
#endif

/*
**  NOTE: Memory for the grib handle is allocated here,
**        but freeing it is up to the calling pgm!!!
*/
grib_handle*
mci_load_one_grib( void* fieldset_ptr )
{
   gribarg*     ga = (gribarg*)fieldset_ptr;
   char*  grib_msg = NULL;
   field* cur_msg  = NULL;
   long int msg_len  = 0;
   grib_handle* gh;
   fieldset* fs;
   int       fi;
   FILE* f;

   if( ! ga )                           /* ensure fieldset exists */
   {
      marslog( LOG_EROR, "mci_load_one_grib: fieldset_ptr is NULL" );
      return NULL;
   }

   fs = ga->v;
   fi = ga->cnt++;                      /*-- field index for the next field (in the fieldset) --*/

   minit();                             /* ensure input request stuff is initialised */

   if( fi < 0 || fi >= fs->count )      /* ensure a field exists */
   {
      marslog( LOG_EROR, "mci_load_one_grib: no more fields" );
      return NULL;
   }

   cur_msg = fs->fields[fi];
   msg_len = cur_msg->length;           /* get msg length and allocate memory */

   grib_msg = (char*)malloc( msg_len*sizeof(char) );

   f = fopen( cur_msg->file->fname, "r" );/* ensure file exists */
   if( ! f )
      marslog( LOG_EXIT|LOG_PERR, "mci_load_one_grib: unable to open GRIB file" );

   if( fseek( f, cur_msg->offset, 0 ) < 0 )/* skip to the current field */
      marslog( LOG_EXIT|LOG_PERR, "mci_load_one_grib: cannot position to GRIB file" );

   if( _readany( f, grib_msg, &msg_len ) )/* read current field */
      marslog( LOG_EXIT|LOG_PERR, "mci_load_one_grib: cannot read GRIB file" );

   fclose( f );                         /* close fieldset file */

   /*-- grib handle to be returned, must be free'd by the calling pgm --*/
   gh = grib_handle_new_from_message_copy( NULL, grib_msg, msg_len );

   free( grib_msg );

   return gh;
}

void
mci_rewind_fieldset( void* fieldset )
{
   fortint index;
   index = get_gribarg_index_from_ptr(fieldset);
   mrewg_( &index );
}

#ifdef MV_ALLOW_DEPRECATED_MCI_NAMES
void
mci_rewind_grib( void* fieldset_ptr )
{
   marslog( LOG_WARN, "'mci_rewind_grib' is deprecated, use 'mci_rewind_fieldset'" );
   mci_rewind_fieldset( fieldset_ptr );
}
#endif

/*
**  NOTE: Memory for the grib id ptr is allocated here,
**        but freeing it is up to the calling pgm!!!
*/
void*
mci_new_fieldset()
{
   /*gribarg* a = (gribarg*)malloc( sizeof(gribarg) );*/
   fortint a;
   mnewg_( &a );
   gribarg *ga = (gribarg*)get_gribarg_ptr_from_index(a);
   return (void*)ga;
}

#ifdef MV_ALLOW_DEPRECATED_MCI_NAMES
void*
mci_new_grib_id_ptr()
{
   marslog( LOG_WARN, "'mci_new_grib_id_ptr' is deprecated, use 'mci_new_fieldset'" );
   return mci_new_fieldset();
}
#endif

void
mci_save_grib( void* fieldset_ptr, grib_handle* gh )
{
   /* writes a GRIB msg into fieldset created by 'mci_new_fieldset' */
   const void* buffer = NULL;
   size_t      size = 0;
   int         err = 0;
   fortint     sizeint = 0;

                                        /* get the coded message in a buffer */
   err = grib_get_message( gh, &buffer, &size );
   if( err )
      marslog(LOG_EXIT|LOG_PERR,"mci_save_grib: error in 'grib_get_message': %d!", err );

   fortint index = get_gribarg_index_from_ptr(fieldset_ptr);

   sizeint = size; /* we need to pass it as a fortint */
   msavebyteg_( &index, (char*)buffer, (fortint*)&sizeint );
}

void
mci_return_fieldset( void* fieldset )
{
   fortint index = get_gribarg_index_from_ptr(fieldset);
   msetg_( &index );          /* append return request with output fieldset params */
}

#ifdef MV_ALLOW_DEPRECATED_MCI_NAMES
void
mci_return_grib( void* grib_id_ptr )
{
   marslog( LOG_WARN, "'mci_return_grib' is deprecated, use 'mci_return_fieldset'" );
   mci_return_fieldset( grib_id_ptr );
}
#endif


/*----------------------------------------------------------*/

int
mci_arg_count()
{
  minit();
  return argc;                          /* return argument count */
}

const char*
mci_args()
{

#define  cBufMax  64

  static int  tbuflen  = 0;
  static char typesbuf[ cBufMax ];
  int i;

  if( tbuflen == 0 )
  {
    minit();

    tbuflen = argc > cBufMax ? cBufMax - 1 : argc;

    for(i=0; i<tbuflen; i++)
      typesbuf[i] = args[i].kind;       /* add a corresponding letter to output string */

    typesbuf[tbuflen] = '\0';           /* terminate output string */
  }

  return typesbuf;                      /* return the string of argument type letters */
}

void
mci_fail( const char* msg )
{
  mfail_( (char*)msg, strlen(msg) );              /* issue error msg and exit! */
}

/*-------------------------------------     m f i _     ---------------------------------*/

/*-------------------------------------------------------- mfi-number
*/
void
mfi_get_number_( fortfloat* d )
{
  *d = mci_get_number();
}

void
mfi_return_number_( fortfloat* d )
{
  mci_return_number( *d );
}

/*-------------------------------------------------------- mfi-string
*/
void
mfi_get_string_( char* s, fortint s_len )
{
  int i=0;
  const char* c_str = mci_get_string(); /* get a C string + memory! */

  strncpy( s, c_str, s_len );           /* use strncpy for safety */

  /* Fortran strings do not use the terminating null
   * character, so we need to remove it and fill the
   * rest with spaces (if 's' longer than 'str'), i.e.
   * we need to convert the C string to a Fortran string:
   */
  if( strlen(c_str) < s_len )           /* append spaces... */
  {
     for( i=s_len; i>strlen(c_str); --i )
        s[i-1] = ' ';
  }
  else if( strlen(c_str) > s_len )      /* ...unless a string overflow */
  {
     marslog( LOG_EROR, "mfi_get_string: string too long: %d chars", strlen(c_str) );
     marslog( LOG_EROR, "mfi_get_string: got only the first %d chars", s_len );
  }
}

void
mfi_return_string_( char* s, fortint s_len )
{
  /* Fortran string 's' does not contain the terminating
   * null character, so we need to add it, i.e.
   * we need to convert the Fortran string to a C string:
   */
  char* str = (char*)malloc( s_len+1 ); /* temporary only */
  strncpy( str, s, s_len );             /* need to use 'strncpy' */
  str[s_len] = '\0';                    /* add the terminator */

  mci_return_string( str );             /* return as a C string */

  free( str );                          /* not needed anymore */
}

/*-------------------------------------------------------- mfi-vector
*/
void
mfi_get_vector_( double* vec, int* length )
{
  double*  v;
  int      l, i;

  mci_get_vector( &v, &l );             /* also allocates memory for 'v' */

  if( l > *length )                     /* check that 'vec' is long enough */
  {
     marslog( LOG_EROR, "mfi_get_vector: vector too long: it has %d elems", l );
     marslog( LOG_EROR, "mfi_get_vector: got only the first %d elements", *length );
     l = *length;
  }

  for( i=0; i<l; ++i )
     vec[i] = v[i];                     /* copy values to Fortran array */
  *length = l;

  free(v);                              /* free the allocated memory */
}

void
mfi_return_vector_( double* vec, int* length )
{
  mci_return_vector( vec, *length );
}

/*-------------------------------------------------------- mfi-fieldset
*/


/* To avoid sending pointers back to the user program, we maintain a list of all
   fieldset_id pointers generated here and return indexes into our list instead.
*/

static int num_fieldsets = 0;
static void **fieldsets = NULL;

static int add_new_mfi_fieldset_pointer (void *new_fieldset_id)
{
    num_fieldsets++;
    fieldsets = realloc (fieldsets, num_fieldsets * sizeof(void *));
    fieldsets[num_fieldsets-1] = new_fieldset_id;
    return num_fieldsets-1;
}

static void *get_fieldset_id_ptr_from_index (fortint index)
{
    return fieldsets[index];
}


void
mfi_get_fieldset_( fortint* fieldset_id, fortint* field_count )
{
  int fc = 0;
  void *new_id_ptr = mci_get_fieldset( &fc );
  int new_id = add_new_mfi_fieldset_pointer(new_id_ptr);
  *fieldset_id = new_id;
  *field_count = fc;
}

void
mfi_rewind_fieldset_( fortint* fieldset_id_index )
{
  mci_rewind_fieldset( get_fieldset_id_ptr_from_index(*fieldset_id_index) );
}


void
mfi_new_fieldset_( fortint* fieldset_id )
{
  void *new_id_ptr = mci_new_fieldset();
  *fieldset_id = add_new_mfi_fieldset_pointer(new_id_ptr);
}

void
mfi_return_fieldset_( fortint* fieldset_id_index )
{
  mci_return_fieldset( get_fieldset_id_ptr_from_index(*fieldset_id_index) );
}


/*-------------------------------------------------------- mfi-misc
*/

void
mfi_args_( fortint* c, char* a, fortint s_len )
{
  /* about Fortran strings: see mfi_get_string_ and mfi_return_string_ */

  int i=0;
  const char* c_str = mci_args();       /* get args as C string   */
  *c = mci_arg_count();                 /* equal to strlen(c_str) */

  strncpy( a, c_str, s_len );           /* copy to Fortran string */

  if( strlen(c_str) < s_len )           /* remove '\0' and add trailing spaces... */
  {
     for( i=s_len; i>strlen(c_str); --i )
        a[i-1] = ' ';
  }
  else if( strlen(c_str) > s_len )      /* ...unless a string overflow */
  {
     marslog( LOG_EROR, "mfi_args: string too long: %d chars", strlen(c_str) );
     marslog( LOG_EROR, "mfi_args: got only the first %d chars", s_len );
  }
}

void
mfi_fail_( char* msg, fortint s_len )
{
  char* str = (char*)malloc( s_len+1 ); /* temporary only */
  strncpy( str, msg, s_len );           /* need to use 'strncpy' */
  str[s_len] = '\0';                    /* add the terminator */

  mci_fail( str );                      /* issue msg and exit !! */

  free( str );                          /* thus we never get here */
}

/*----------- mifi = M(acro) I(nternal) F(ortran) I(nterface) ------------*/

/*
 *  'mifi_get_msg_length_' is called from Fortran code of 'mfi_load_one_grib'
 */
void
mifi_get_msg_length_( fortint* fieldset_id_index, fortint* msg_len )
{
   int current;
   void *fieldset_id = get_fieldset_id_ptr_from_index(*fieldset_id_index);
   gribarg* ga = (gribarg*)(fieldset_id);
   if( ! ga )                           /* ensure fieldset exists */
   {
      marslog( LOG_EROR, "mfi_load_one_grib: fieldset_id is NULL" );
      return;
   }

   current = ga->cnt;
   if( current < 0 || current >= ga->v->count ) /* ensure a field exists */
   {
      marslog( LOG_EROR, "mfi_load_one_grib: no more fields" );
      return;
   }

   *msg_len = ga->v->fields[current]->length;   /* get length from inside the struct */
   return;
}

/*
 *  'mifi_load_one_grib_to_memory_' is called from Fortran code of 'mfi_load_one_grib'
 */
void
mifi_load_one_grib_to_memory_( fortint* fieldset_id_index, char* grib_in_memory )
{
   void *fieldset_id = get_fieldset_id_ptr_from_index(*fieldset_id_index);
   gribarg*     ga = (gribarg*)(fieldset_id);
   field* cur_msg  = NULL;
   long int msg_len  = 0;
   grib_handle* gh;
   fieldset* fs;
   int       fi;
   FILE* f;

   if( ! ga )                           /* ensure fieldset exists */
   {
      marslog( LOG_EROR, "mfi_load_one_grib: fieldset_id is NULL" );
      return;
   }

   fs = ga->v;                          /* fieldset pointer */
   fi = ga->cnt++;                      /* index for the next field within the fieldset */

   minit();                             /* ensure input request stuff is initialised */

   if( fi < 0 || fi >= fs->count )      /* ensure a field exists */
   {
      marslog( LOG_EROR, "mfi_load_one_grib: no more fields" );
      return;
   }

   cur_msg = fs->fields[fi];
   msg_len = cur_msg->length;           /* get msg length and allocate memory */

   f = fopen( cur_msg->file->fname, "r" );/* ensure file exists */
   if( ! f )
      marslog( LOG_EXIT|LOG_PERR, "mfi_load_one_grib: unable to open GRIB file" );

   if( fseek( f, cur_msg->offset, 0 ) < 0 )/* skip to the current field */
      marslog( LOG_EXIT|LOG_PERR, "mfi_load_one_grib: cannot position to GRIB file" );

   if( _readany( f, grib_in_memory, &msg_len ) )/* read current field */
      marslog( LOG_EXIT|LOG_PERR, "mfi_load_one_grib: cannot read GRIB file" );

   fclose( f );                         /* close fieldset file */
}


/*
 *  'mifi_save_one_grib_to_file_' is called from Fortran code of 'mfi_save_grib'
 */
void
mifi_save_one_grib_to_file_( fortint* fieldset_id_index, char* grib_data, fortint *bytecount )
{
   void *fieldset_id = get_fieldset_id_ptr_from_index(*fieldset_id_index);
   fortint ga_index = get_gribarg_index_from_ptr(fieldset_id);

   msavebyteg_(&ga_index, grib_data, bytecount);
}
