cforthdf.h

GIS系统支持库Geospatial Data Abstraction Library代码.GDAL is a translator library for raster geospatial dat

                     char* cstr; char *fstr; int elem_len; int sizeofcstr;
#endif
{ int i,j;
/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
   Useful size of string must be the same in both languages. */
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; }

/* Convert a vector of FORTRAN strings into C strings. */
#ifndef __CF__KnR
static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
#else
static char *f2cstrv(      fstr,       cstr,     elem_len,     sizeofcstr)
                     char *fstr; char* cstr; int elem_len; int sizeofcstr; 
#endif
{ int i,j;
/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
   Useful size of string must be the same in both languages. */
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; }

/* kill the trailing char t's in string s. */
#ifndef __CF__KnR
static char *kill_trailing(char *s, char t)
#else
static char *kill_trailing(      s,      t) char *s; char t;
#endif
{char *e; 
e = s + strlen(s);
if (e>s) {                           /* Need this to handle NULL 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; }

/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally 
points to the terminating '\0' of s, but may actually point to anywhere in s.
s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
If e<s string s is left unchanged. */ 
#ifndef __CF__KnR
static char *kill_trailingn(char *s, char t, char *e)
#else
static char *kill_trailingn(      s,      t,       e) char *s; char t; char *e;
#endif
{ 
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; }

/* Note the following assumes that any element which has t's to be chopped off,
does indeed fill the entire element. */
#ifndef __CF__KnR
static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
#else
static char *vkill_trailing(      cstr,     elem_len,     sizeofcstr,      t)
                            char* cstr; int elem_len; int sizeofcstr; char t;
#endif
{ 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; }

#ifdef vmsFortran
typedef struct dsc$descriptor_s fstring;
#define DSC$DESCRIPTOR_A(DIMCT)  		                               \
struct {                                                                       \
  unsigned short dsc$w_length;	        unsigned char	 dsc$b_dtype;	       \
  unsigned char	 dsc$b_class;	                 char	*dsc$a_pointer;	       \
           char	 dsc$b_scale;	        unsigned char	 dsc$b_digits;         \
  struct {                                                                     \
    unsigned		       : 3;	  unsigned dsc$v_fl_binscale : 1;      \
    unsigned dsc$v_fl_redim    : 1;       unsigned dsc$v_fl_column   : 1;      \
    unsigned dsc$v_fl_coeff    : 1;       unsigned dsc$v_fl_bounds   : 1;      \
  } dsc$b_aflags;	                                                       \
  unsigned char	 dsc$b_dimct;	        unsigned long	 dsc$l_arsize;	       \
           char	*dsc$a_a0;	                 long	 dsc$l_m [DIMCT];      \
  struct {                                                                     \
    long dsc$l_l;                         long dsc$l_u;                        \
  } dsc$bounds [DIMCT];                                                        \
}
typedef DSC$DESCRIPTOR_A(1) fstringvector;
/*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
  typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
#define initfstr(F,C,ELEMNO,ELEMLEN)                                           \
( (F).dsc$l_arsize=  ( (F).dsc$w_length                        =(ELEMLEN) )    \
                    *( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO)  ),   \
  (F).dsc$a_a0    =  ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length          ,(F))

#else
#define _NUM_ELEMS      -1
#define _NUM_ELEM_ARG   -2
#define NUM_ELEMS(A)    A,_NUM_ELEMS
#define NUM_ELEM_ARG(B) *A##B,_NUM_ELEM_ARG
#define TERM_CHARS(A,B) A,B
#ifndef __CF__KnR
static int num_elem(char *strv, unsigned elem_len, int term_char, int num_term)
#else
static int num_elem(      strv,          elem_len,     term_char,     num_term)
                    char *strv; unsigned elem_len; int term_char; int num_term;
#endif
/* elem_len is the number of characters in each element of strv, the FORTRAN
vector of strings. The last element of the vector must begin with at least
num_term term_char characters, so that this routine can determine how 
many elements are in the vector. */
{
unsigned num,i;
if (num_term == _NUM_ELEMS || num_term == _NUM_ELEM_ARG) 
  return term_char;
if (num_term <=0) num_term = elem_len;
for (num=0; ; num++) {
  for (i=0; (int) i<num_term && *strv==(char) term_char; i++,strv++);
  if ((int) i==num_term) break;
  else strv += elem_len-i;
}
return num;
}
#endif
/*-------------------------------------------------------------------------*/

/*           UTILITIES FOR C TO USE STRINGS IN FORTRAN COMMON BLOCKS       */

/* C string TO Fortran Common Block STRing. */
/* DIM is the number of DIMensions of the array in terms of strings, not
   characters. e.g. char a[12] has DIM = 0, char a[12][4] has DIM = 1, etc. */
#define C2FCBSTR(CSTR,FSTR,DIM)                                                \
 c2fstrv((char *)CSTR, (char *)FSTR, sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,    \
         sizeof(FSTR)+cfelementsof(FSTR,DIM))

/* Fortran Common Block string TO C STRing. */
#define FCB2CSTR(FSTR,CSTR,DIM)                                                \
 vkill_trailing(f2cstrv((char *)FSTR, (char *)CSTR,                            \
                        sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                 \
                        sizeof(FSTR)+cfelementsof(FSTR,DIM)),                  \
                sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                         \
                sizeof(FSTR)+cfelementsof(FSTR,DIM), ' ')

#define cfDEREFERENCE0
#define cfDEREFERENCE1 *
#define cfDEREFERENCE2 **
#define cfDEREFERENCE3 ***
#define cfDEREFERENCE4 ****
#define cfDEREFERENCE5 *****
#define cfelementsof(A,D) (sizeof(A)/sizeof(cfDEREFERENCE##D(A)))

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

/*               UTILITIES FOR C TO CALL FORTRAN SUBROUTINES               */

/* Define lookup tables for how to handle the various types of variables.  */

#ifdef OLD_VAXC                                /* Prevent %CC-I-PARAMNOTUSED. */
#pragma nostandard
#endif

static int __cfztringv[30];       /* => 30 == MAX # of arg.'s C can pass to a */
#define ZTRINGV_NUM(I) I          /*          FORTRAN function.               */
#define ZTRINGV_ARGF(I) __cfztringv[I]
#define ZTRINGV_ARGS(I) B##I

#define VPPBYTE         VPPINT
#define VPPDOUBLE       VPPINT
#define VPPFLOAT        VPPINT
#define VPPINT(    A,B) int  B = (int)A;   /* For ZSTRINGV_ARGS */
#define VPPLOGICAL(A,B) int *B;         /* Returning LOGICAL in FUNn and SUBn.*/
#define VPPLONG         VPPINT
#define VPPSHORT        VPPINT

#define VCF(TN,I)       _INT(3,V,TN,A##I,B##I)
#define VVCF(TN,AI,BI)  _INT(3,V,TN,AI,BI)
#define VINT(       T,A,B) typeP##T##VVVVVVV B = A;
#define VINTV(      T,A,B)
#define VINTVV(     T,A,B)
#define VINTVVV(    T,A,B)
#define VINTVVVV(   T,A,B)
#define VINTVVVVV(  T,A,B)
#define VINTVVVVVV( T,A,B)
#define VINTVVVVVVV(T,A,B)
#define VPINT(      T,A,B) VP##T(A,B)
#define VPVOID(     T,A,B)
#ifdef apolloFortran
#define VROUTINE(   T,A,B) void (*B)() = (void (*)())A;
#else
#define VROUTINE(   T,A,B)
#endif
#define VSIMPLE(    T,A,B)
#ifdef vmsFortran
#define VSTRING(    T,A,B) static struct {fstring f; unsigned clen;} B =       \
                                       {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
#define VPSTRING(   T,A,B) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
#define VSTRINGV(   T,A,B) static fstringvector B =                            \
  {sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
#define VPSTRINGV(  T,A,B) static fstringvector B =                            \
          {0,DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
#else
#define VSTRING(    T,A,B) struct {unsigned short clen, flen;} B;
#define VSTRINGV(   T,A,B) struct {char *s, *fs; unsigned flen;} B;
#define VPSTRING(   T,A,B) int     B;
#define VPSTRINGV(  T,A,B) struct {char *fs; unsigned short sizeofA, flen;} B;
#endif
#define VZTRINGV         VSTRINGV
#define VPZTRINGV        VPSTRINGV

/* Note that the actions of the A table were performed inside the AA table.
   VAX Ultrix vcc, and HP-UX cc, didn't evaluate arguments to functions left to
   right, so we had to split the original table into the current robust two. */
#define ACF(NAME,TN,AI,I)  STR_##TN(4,A,NAME,I,AI,B##I)
#define ALOGICAL( M,I,A,B) B=C2FLOGICAL(B);
#define APLOGICAL(M,I,A,B) A=C2FLOGICAL(A);
#define ASTRING(  M,I,A,B) CSTRING(A,B,sizeof(A))
#define APSTRING( M,I,A,B) CPSTRING(A,B,sizeof(A))
#ifdef vmsFortran
#define AATRINGV( M,I,A,B, sA,filA,silA)                                       \
 initfstr(B,malloc((sA)-(filA)),(filA),(silA)-1),                              \
          c2fstrv(A[0],B.dsc$a_pointer,(silA),(sA));
#define APATRINGV(M,I,A,B, sA,filA,silA)                                       \
 initfstr(B,A[0],(filA),(silA)-1),c2fstrv(A[0],A[0],(silA),(sA));
#else
#define AATRINGV( M,I,A,B, sA,filA,silA)                                       \
 (B.s=malloc((sA)-(filA)),B.fs=c2fstrv(A[0],B.s,(B.flen=(silA)-1)+1,(sA)));
#define APATRINGV(M,I,A,B, sA,filA,silA)                                       \
 B.fs=c2fstrv(A[0],A[0],(B.flen=(silA)-1)+1,B.sizeofA=(sA));
#endif
#define ASTRINGV( M,I,A,B)                                                     \
  AATRINGV( M,I,A,B,sizeof(A),firstindexlength(A),secondindexlength(A)) 
#define APSTRINGV(M,I,A,B)                                                     \
 APATRINGV( M,I,A,B,sizeof(A),firstindexlength(A),secondindexlength(A)) 
#define AZTRINGV( M,I,A,B) AATRINGV( M,I,A,B,                                  \
                    (M##_ELEMS_##I)*(( M##_ELEMLEN_##I)+1),            \
                              (M##_ELEMS_##I),(M##_ELEMLEN_##I)+1) 
#define APZTRINGV(M,I,A,B) APATRINGV( M,I,A,B,                                 \
                    (M##_ELEMS_##I)*(( M##_ELEMLEN_##I)+1),            \
                              (M##_ELEMS_##I),(M##_ELEMLEN_##I)+1) 

#define AAPPBYTE(   A,B) &A
#define AAPPDOUBLE( A,B) &A
#define AAPPFLOAT(  A,B) PPFLOATVVVVVVV &A
#define AAPPINT(    A,B) &A
#define AAPPLOGICAL(A,B) B= &A         /* B used to keep a common W table. */
#define AAPPLONG(   A,B) &A
#define AAPPSHORT(  A,B) &A

#define AACF(TN,AI,I,C) _SEP_(TN,C,COMMA) _INT(3,AA,TN,AI,B##I)
#define AAINT(       T,A,B) &B
#define AAINTV(      T,A,B) PP##T##VVVVVV A
#define AAINTVV(     T,A,B) PP##T##VVVVV  A[0]
#define AAINTVVV(    T,A,B) PP##T##VVVV   A[0][0]
#define AAINTVVVV(   T,A,B) PP##T##VVV    A[0][0][0]
#define AAINTVVVVV(  T,A,B) PP##T##VV     A[0][0][0][0]
#define AAINTVVVVVV( T,A,B) PP##T##V      A[0][0][0][0][0]
#define AAINTVVVVVVV(T,A,B) PP##T           A[0][0][0][0][0][0]
#define AAPINT(      T,A,B) AAP##T(A,B)
#define AAPVOID(     T,A,B) (void *) A
#ifdef apolloFortran
#define AAROUTINE(   T,A,B) &B
#else
#define AAROUTINE(   T,A,B)  (void(*)())A
#endif
#define AASTRING(    T,A,B) CCSTRING(T,A,B)
#define AAPSTRING(   T,A,B) CCPSTRING(T,A,B)
#ifdef vmsFortran
#define AASTRINGV(   T,A,B) &B
#else
#ifdef CRAYFortran
#define AASTRINGV(   T,A,B) _cptofcd(B.fs,B.flen)
#else
#define AASTRINGV(   T,A,B) B.fs
#endif
#endif
#define AAPSTRINGV      AASTRINGV
#define AAZTRINGV       AASTRINGV
#define AAPZTRINGV      AASTRINGV