cfortran.h

Cfortran is useful for mixing language programing when you want call some C function in your FORTRAN

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) *_2(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 = (int)elem_len;
for (num=0; ; num++) {
  for (i=0; i<(unsigned)num_term && *strv==term_char; i++,strv++);
  if (i==(unsigned)num_term) break;
  else strv += elem_len-i;
}
return (int)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

#define ZTRINGV_NUM(I)       I
#define ZTRINGV_ARGFP(I) (*(_2(A,I))) /* Undocumented. For PINT, etc. */
#define ZTRINGV_ARGF(I) _2(A,I)
#ifdef CFSUBASFUN
#define ZTRINGV_ARGS(I) ZTRINGV_ARGF(I)
#else
#define ZTRINGV_ARGS(I) _2(B,I)
#endif

#define    PBYTE_cfVP(A,B) PINT_cfVP(A,B)
#define  PDOUBLE_cfVP(A,B)
#define   PFLOAT_cfVP(A,B)
#ifdef ZTRINGV_ARGS_allows_Pvariables
/* This allows Pvariables for ARGS. ARGF machinery is above ARGFP.
 * B is not needed because the variable may be changed by the Fortran routine,
 * but because B is the only way to access an arbitrary macro argument.       */
#define     PINT_cfVP(A,B) int  B = (int)A;              /* For ZSTRINGV_ARGS */
#else
#define     PINT_cfVP(A,B)
#endif
#define PLOGICAL_cfVP(A,B) int *B;      /* Returning LOGICAL in FUNn and SUBn */
#define    PLONG_cfVP(A,B) PINT_cfVP(A,B)
#define   PSHORT_cfVP(A,B) PINT_cfVP(A,B)

#define        VCF_INT_S(T,A,B) _(T,VVVVVVV_cfTYPE) B = A;
#define        VCF_INT_F(T,A,B) _(T,_cfVCF)(A,B)
/* _cfVCF table is directly mapped to _cfCCC table. */
#define     BYTE_cfVCF(A,B)
#define   DOUBLE_cfVCF(A,B)
#if !defined(__CF__KnR)
#define    FLOAT_cfVCF(A,B)
#else
#define    FLOAT_cfVCF(A,B) FORTRAN_REAL B = A;
#endif
#define      INT_cfVCF(A,B)
#define  LOGICAL_cfVCF(A,B)
#define     LONG_cfVCF(A,B)
#define    SHORT_cfVCF(A,B)

/* 980416
   Cast (void (*)(CF_NULL_PROTO)) causes SunOS CC 4.2 occasionally to barf,
   while the following equivalent typedef is fine.
   For consistency use the typedef on all machines.
 */
typedef void (*cfCAST_FUNCTION)(CF_NULL_PROTO);

#define VCF(TN,I)       _Icf4(4,V,TN,_(A,I),_(B,I),F)
#define VVCF(TN,AI,BI)  _Icf4(4,V,TN,AI,BI,S)
#define        INT_cfV(T,A,B,F) _(VCF_INT_,F)(T,A,B)
#define       INTV_cfV(T,A,B,F)
#define      INTVV_cfV(T,A,B,F)
#define     INTVVV_cfV(T,A,B,F)
#define    INTVVVV_cfV(T,A,B,F)
#define   INTVVVVV_cfV(T,A,B,F)
#define  INTVVVVVV_cfV(T,A,B,F)
#define INTVVVVVVV_cfV(T,A,B,F)
#define PINT_cfV(      T,A,B,F) _(T,_cfVP)(A,B)
#define PVOID_cfV(     T,A,B,F)
#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
#define    ROUTINE_cfV(T,A,B,F) void (*B)(CF_NULL_PROTO) = (cfCAST_FUNCTION)A;
#else
#define    ROUTINE_cfV(T,A,B,F)
#endif
#define     SIMPLE_cfV(T,A,B,F)
#ifdef vmsFortran
#define     STRING_cfV(T,A,B,F) static struct {fstring f; unsigned clen;} B =  \
                                       {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
#define    PSTRING_cfV(T,A,B,F) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
#define    STRINGV_cfV(T,A,B,F) 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   PSTRINGV_cfV(T,A,B,F) 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     STRING_cfV(T,A,B,F) struct {unsigned int clen, flen;} B;
#define    STRINGV_cfV(T,A,B,F) struct {char *s, *fs; unsigned flen;} B;
#define    PSTRING_cfV(T,A,B,F) int     B;
#define   PSTRINGV_cfV(T,A,B,F) struct{char *fs; unsigned int sizeofA,flen;}B;
#endif
#define    ZTRINGV_cfV(T,A,B,F)  STRINGV_cfV(T,A,B,F)
#define   PZTRINGV_cfV(T,A,B,F) PSTRINGV_cfV(T,A,B,F)

/* 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)      _(TN,_cfSTR)(4,A,NAME,I,AI,_(B,I),0)
#define   DEFAULT_cfA(M,I,A,B)
#define   LOGICAL_cfA(M,I,A,B) B=C2FLOGICAL(B);
#define  PLOGICAL_cfA(M,I,A,B) A=C2FLOGICAL(A);
#define    STRING_cfA(M,I,A,B)  STRING_cfC(M,I,A,B,sizeof(A))
#define   PSTRING_cfA(M,I,A,B) PSTRING_cfC(M,I,A,B,sizeof(A))
#ifdef vmsFortran
#define  AATRINGV_cfA(    A,B, sA,filA,silA)                                   \
 initfstr(B,_cf_malloc((sA)-(filA)),(filA),(silA)-1),                          \
          c2fstrv(A,B.dsc$a_pointer,(silA),(sA));
#define APATRINGV_cfA(    A,B, sA,filA,silA)                                   \
 initfstr(B,A,(filA),(silA)-1),c2fstrv(A,A,(silA),(sA));
#else
#define  AATRINGV_cfA(    A,B, sA,filA,silA)                                   \
     (B.s=_cf_malloc((sA)-(filA)),B.fs=c2fstrv(A,B.s,(B.flen=(silA)-1)+1,(sA)));
#define APATRINGV_cfA(    A,B, sA,filA,silA)                                   \
 B.fs=c2fstrv(A,A,(B.flen=(silA)-1)+1,B.sizeofA=(sA));
#endif
#define   STRINGV_cfA(M,I,A,B)                                                 \
    AATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
#define  PSTRINGV_cfA(M,I,A,B)                                                 \
   APATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
#define   ZTRINGV_cfA(M,I,A,B)  AATRINGV_cfA( (char *)A,B,                     \
                    (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1),                \
                              (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
#define  PZTRINGV_cfA(M,I,A,B) APATRINGV_cfA( (char *)A,B,                     \
                    (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1),                \
                              (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)

#define    PBYTE_cfAAP(A,B) &A
#define  PDOUBLE_cfAAP(A,B) &A
#define   PFLOAT_cfAAP(A,B) FLOATVVVVVVV_cfPP &A
#define     PINT_cfAAP(A,B) &A
#define PLOGICAL_cfAAP(A,B) B= &A         /* B used to keep a common W table. */
#define    PLONG_cfAAP(A,B) &A
#define   PSHORT_cfAAP(A,B) &A

#define AACF(TN,AI,I,C) _SEP_(TN,C,cfCOMMA) _Icf(3,AA,TN,AI,_(B,I))
#define        INT_cfAA(T,A,B) &B
#define       INTV_cfAA(T,A,B) _(T,VVVVVV_cfPP) A
#define      INTVV_cfAA(T,A,B) _(T,VVVVV_cfPP)  A[0]
#define     INTVVV_cfAA(T,A,B) _(T,VVVV_cfPP)   A[0][0]
#define    INTVVVV_cfAA(T,A,B) _(T,VVV_cfPP)    A[0][0][0]
#define   INTVVVVV_cfAA(T,A,B) _(T,VV_cfPP)     A[0][0][0][0]
#define  INTVVVVVV_cfAA(T,A,B) _(T,V_cfPP)      A[0][0][0][0][0]
#define INTVVVVVVV_cfAA(T,A,B) _(T,_cfPP)       A[0][0][0][0][0][0]
#define       PINT_cfAA(T,A,B) _(T,_cfAAP)(A,B)
#define      PVOID_cfAA(T,A,B) (void *) A
#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
#define    ROUTINE_cfAA(T,A,B) &B
#else
#define    ROUTINE_cfAA(T,A,B) (cfCAST_FUNCTION)A
#endif
#define     STRING_cfAA(T,A,B)  STRING_cfCC(T,A,B)
#define    PSTRING_cfAA(T,A,B) PSTRING_cfCC(T,A,B)
#ifdef vmsFortran
#define    STRINGV_cfAA(T,A,B) &B
#else
#ifdef CRAYFortran
#define    STRINGV_cfAA(T,A,B) _cptofcd(B.fs,B.flen)
#else
#define    STRINGV_cfAA(T,A,B) B.fs
#endif
#endif
#define   PSTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
#define    ZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
#define   PZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)

#if defined(vmsFortran) || defined(CRAYFortran)
#define JCF(TN,I)
#define KCF(TN,I)
#else
#define JCF(TN,I)    _(TN,_cfSTR)(1,J,_(B,I), 0,0,0,0)
#if defined(AbsoftUNIXFortran)
#define  DEFAULT_cfJ(B) ,0
#else
#define  DEFAULT_cfJ(B)
#endif
#define  LOGICAL_cfJ(B) DEFAULT_cfJ(B)
#define PLOGICAL_cfJ(B) DEFAULT_cfJ(B)
#define   STRING_cfJ(B) ,B.flen
#define  PSTRING_cfJ(B) ,B
#define  STRINGV_cfJ(B) STRING_cfJ(B)
#define PSTRINGV_cfJ(B) STRING_cfJ(B)
#define  ZTRINGV_cfJ(B) STRING_cfJ(B)
#define PZTRINGV_cfJ(B) STRING_cfJ(B)

/* KCF is identical to DCF, except that KCF ZTRING is not empty. */
#define KCF(TN,I)    _(TN,_cfSTR)(1,KK,_(B,I), 0,0,0,0)
#if defined(AbsoftUNIXFortran)
#define  DEFAULT_cfKK(B) , unsigned B
#else
#define  DEFAULT_cfKK(B)
#endif
#define  LOGICAL_cfKK(B) DEFAULT_cfKK(B)