C calls to FORTRAN made easy
burkhard burow
burow at cernvax.cern.ch
Fri Feb 15 04:25:37 AEST 1991
CFORTRAN is an easy-to-use bridge between C and FORTRAN. Names of routines and
their arguments are made identical in either language.
e.g.
C the original FORTRAN call to a FORTRAN routine
CALL HBOOK1(1,'pT spectrum of pi+',100,0.,5.,0.)
/* calling a FORTRAN routine from C */
HBOOK1(1,"pT spectrum of pi+",100,0.,5.,0.);
All setup in 2 machine-independant 'instructions' per routine.
e.g.
PROTOCCALLSFSUB6(hbook1,INT,STRING,INT,FLOAT,FLOAT,FLOAT)
#define HBOOK1(ID,CHTITLE,NX,XMI,XMA,VMX) \
CCALLSFSUB6(hbook1,INT,STRING,INT,FLOAT,FLOAT,FLOAT, \
ID,CHTITLE,NX,XMI,XMA,VMX)
The setup is digested by cc with the help of a single header file: cfortran.h.
It's easy, it's fun, and you never have to worry about FORTRAN argument passing
mechanisms again.
Thank you John H.Merritt for your posting on FORTRAN's mechanism for passing
vectors of strings.
cfortran.doc, some examples in cfortex.c and cfortex.f, and cfortran.h follow.
Comments, complaints, and bug reports are of course entertained.
enjoy, INTERNET: burow%13313.hepnet at csa3.lbl.gov
burkhard
-----------------------cut here for cfortran.doc------------------------------
/* cfortran.doc */
/* Burkhard Burow, burow%13313.hepnet at csa3.lbl.gov, U. of Toronto, 1991. */
CFORTRAN 1.0 for Silicon Graphics
History:
- 1.0 for VAX VMS using C 3.1 and FORTRAN 5.4. Oct. '90.
- 1.0 for Silicon Graphics using Mips Computer System 2.0 f77 and cc. Feb. '91.
I Introduction
--------------
CFORTRAN provides for a completely transparent, machine
independant, interface between C and FORTRAN routines (= subroutines and/or
functions).
The complete CFORTRAN package consists of 4 files. They are this introduction,
cfortran.doc, the engine in cfortran.h, examples in cfortex.c and cfortex.for.
CFORTRAN was created under VAX VMS. This port to the SGI includes the
'C calls FORTRAN' half of the package. The second half which allows FORTRAN to call
C routines has yet to be ported. The second half shares the syntax of this half
and I believe is easier to use than mkf2c.
-----
Example - CFORTRAN has been used to make the C header file hbook.h,
which then gives any C programmer, e.g. example.c, full and
completely transparent access to CERN's HBOOK library of routines.
Each HBOOK routine required about 3 lines of simple code in
hbook.h. The example also demonstrates how FORTRAN common blocks
are defined and used.
/* hbook.h */
#include "cfortran.h"
:
PROTOCCALLSFSUB6(hbook1,INT,STRING,INT,FLOAT,FLOAT,FLOAT)
#define HBOOK1(ID,CHTITLE,NX,XMI,XMA,VMX) \
CCALLSFSUB6(hbook1,INT,STRING,INT,FLOAT,FLOAT,FLOAT, \
ID,CHTITLE,NX,XMI,XMA,VMX)
:
/* end hbook.h */
/* example.c */
#include "hbook.h"
:
typedef struct {
int lines;
int status[SIZE];
float p[SIZE]; /* momentum */
} FAKE_DEF;
#define FAKE COMMON_BLOCK(fake)
extern FAKE_DEF FAKE;
:
main ()
{
:
HBOOK1(1,"pT spectrum of pi+",100,0.,5.,0.);
/* c.f. the call in FORTRAN:
CALL HBOOK1(1,'pT spectrum of pi+',100,0.,5.,0.)
*/
:
FAKE.p[7]=1.0;
:
}
N.B. i) The routine is language independant.
ii) hbook.h is machine independant.
iii) Applications of CFORTRAN'd routines are machine independant.
II Using CFORTRAN
-----------------
The user is asked to look at the source files CFORTEX.C, CFORTEX.FOR for
clarification by example.
N.B. CFORTRAN (ab)uses the null comment, /**/, kludge for the ANSI C
preprocessor concatenation, ##, operator. On the SGI this kludge is sensitive
to blanks prepending arguments to macros.
THEREFORE IN THE FOLLOWING MACRO DEFINITIONS YOU MAY NOT PREPEND argtype_i NOR
routine_type WITH BLANK, ' ', CHARACTERS.
i) Calling FORTRAN routines from C:
FORTRAN common blocks are set up with the following construct:
#define COMMON_BLOCK_NAME COMMON_BLOCK(common_block_name)
where common_block_name is given in the case shown. This construct exists to
ensure that C code accessing the common block is machine independant.
FORTRAN routines are prototyped by the following two macros.
PROTOCCALLSFSUBn(routine_name, argtype_1, ..., argtype_n)
or
PROTOCCALLSFFUNn(routine_type, routine_name, argtype_1, ..., argtype_n)
and are defined respectively by the following two macro usages.
#define ROUTINE_NAME(argname_1,...,argname_n) \
CCALLSFSUBn(routine_name, argtype_1,...,argtype_n, \
argname_1,...,argname_n)
#define ROUTINE_NAME(argname_1,...,argname_n) \
CCALLSFFUNn(routine_name, argtype_1,...,argtype_n, \
argname_1,...,argname_n)
Where:
'n' = 0->7 (easily expanded in CFORTRAN.H to >7) stands for the number of
arguments to the routine.
ROUTINE_NAME = the C name of the routine (IN UPPERCASE LETTERS).
routine_name = the FORTRAN name of the routine (IN lowercase LETTERS).
routine_type = the type of argument returned by FORTRAN functions.
= DOUBLE, FLOAT, INT, LOGICAL, LONG, STRING.
argtype_i = the type of argument passed to the FORTRAN routine and must be
consistent in the definition and prototyping of the routine s.a.
= DOUBLE, FLOAT, INT, LOGICAL, LONG, STRING.
For vectors, i.e. 1 dim. arrays use
= DOUBLEV, FLOATV, INTV, LOGICALV, LONGV.
For vectors of vectors, 2 dim. arrays use
= DOUBLEVV, FLOATVV, INTVV, LOGICALVV, LONGVV, STRINGV.
For n-dim. arrays use
= DOUBLEV..nV's..V, FLOATV..V, INTV..V, LOGICALV..V, LONGV..V.
N.B. Array dimensions and types are checked by the C compiler.
For routines changing the values of an
argument, the keyword is prepended by a 'P'.
= PDOUBLE, PFLOAT, PINT, PLOGICAL, PLONG, PSTRING, PSTRINGV.
For exceptional arguments which require no massaging to fit the
argument passing mechanisms use
= PVOID.
But note that although PVOID could be used to describe all
array arguments on most (all?) machines , it shouldn't be
because the C compiler can no longer check the type and
dimension of the array.
argname_i = any valid unique C tag, but must be consistent in the definition
as shown.
STRINGV refers to vector of strings. Elements of STRINGV arays return with
blanks padding the right. PSTRING(V) elements have trailing blanks stripped
before returning. N.B. CFORTRAN uses strlen((P)STRING arg.) to determine the
length of the string as seen by the FORTRAN routine. In order to determine the
dimensions of (P)STRINGV, CFORTRAN requires that the last element or at least 2
consecutive string elements be nonnull and array must have its memory allocated
at compile time, i.e. the array must be a valid argument to the sizeof
operator. For STRING [not (P) nor (V)] arguments only, the NULL pointer can be
passed.
This list is not neccessarily complete. It is easy for CFORTRAN to handle a new
type not in this list.
N.B. The FORTRAN routines are called using macro expansions, therefore the
usual caveats for expressions in arguments apply. The expressions to the
routines may be evaluated more than once, leading to lower performance and in
the worst case bizzare bugs.
ii) Calling C routines from FORTRAN:
Not yet ported from VAX VMS to the SGI.
THIS SOFTWARE IS PUBLIC DOMAIN. IT MAY BE FREELY COPIED AND USED EVERYWHERE. IT
MAY BE DISTRIBUTED WITH NON-COMMERCIAL PRODUCTS, ASSUMING PROPER CREDIT TO THE
AUTHOR IS GIVEN, BUT IT SHOULD NOT BE RESOLD. IF YOU WANT TO DISTRIBUTE THE
SOFTWARE WITH COMMERCIAL PRODUCTS, CONTACT THE AUTHOR.
THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST
OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
VAX VMS, Silicon Graphics (SGI), and Mips are registered trademarks.
/* end: cfortran.doc */
-------------------cut here for cfortex.c-------------------------------------
/* cfortex.c */
/* Burkhard Burow, burow%13313.hepnet at csa3.lbl.gov, U. of Toronto, 1991. */
#include <stdio.h>
#include "cfortran.h"
#define REV_SELECT 1 /* To see the various examples select one of:
EASY_SELECT, ST_SELECT, FT_SELECT S1_SELECT ABC_SELECT R_SELECT
REV_SELECT. */
#ifdef EASY_SELECT
PROTOCCALLSFSUB2(easy,PINT,INT)
#define EASY(A,B) CCALLSFSUB2(easy,PINT,INT, A,B)
main() {
int a;
printf("\nEASY EXAMPLE\n");
EASY(a,7);
printf("The FORTRAN routine easy(a,7) returns a = %d\n", a);
}
#endif
#ifdef ST_SELECT
PROTOCCALLSFSUB3(st,PSTRINGV,STRINGV,FLOAT)
#define ST(A,B,C) CCALLSFSUB3(st,PSTRINGV,STRINGV,FLOAT,A,B,C)
main() {
static char v[][5] = {"0000", "1", "22", ""};
static char w[][9] = {"", "bb","ccc","dddd"};
ST(v, w, 10.);
printf("main:v=%s,%s,%s,%s. PSTRINGV => Has had trailing blanks stripped.\n",
v[0],v[1],v[2],v[3]);
printf("main:w=%s,%s,%s,%s. STRINGV => Trailing blanks from FORTRAN call.\n"
,w[0],w[1],w[2],w[3]);
}
#endif
#ifdef FT_SELECT
PROTOCCALLSFFUN3(STRING,ft,PSTRINGV,STRINGV,FLOAT)
#define FT(A,B,C) CCALLSFFUN3(ft,PSTRINGV,STRINGV,FLOAT,A,B,C)
main() {
static char v[][5] = {"0000", "1", "22", ""};
static char w[][9] = {"", "bb","ccc","dddd"};
float a = 10.0;
printf("FT(v, w, a); returns:%s.\n",FT(v, w, a));
printf("main:v=%s,%s,%s,%s. PSTRINGV => Has had trailing blanks stripped.\n",
v[0],v[1],v[2],v[3]);
printf("main:w=%s,%s,%s,%s. STRINGV => Trailing blanks from FORTRAN call.\n"
,w[0],w[1],w[2],w[3]);
}
#endif
#ifdef S1_SELECT
PROTOCCALLSFSUB1(s1,PSTRING)
#define S1(A1) CCALLSFSUB1(s1,PSTRING,A1)
PROTOCCALLSFSUB1(forstr1,PSTRING)
#define FORSTR1(A1) CCALLSFSUB1(forstr1,PSTRING,A1)
main() {
static char b[] = "abcdefghij", forb[13] = "abcdefghijkl";
S1(b); FORSTR1(forb);
printf("s1(b) returns b = %s; forstr1(forb) = returns forb = %s;\n", b, forb);
}
#endif
#ifdef ABC_SELECT
PROTOCCALLSFSUB3(abc,STRING,PSTRING,PSTRING)
#define ABC(A1,A2,A3) CCALLSFSUB3(abc,STRING,PSTRING,PSTRING,A1,A2,A3)
main() {
static char aa[] = "one ", bb[] = "two ", cc[] = "three"; int i;
for (i=0; i<10; i++) {printf("%s;%s;%s;\n",aa,bb,cc); ABC(aa,bb,cc);}
}
#endif
#ifdef R_SELECT
PROTOCCALLSFFUN1(FLOAT,r,INT)
#define R(A1) CCALLSFFUN1(r,INT,A1)
PROTOCCALLSFFUN0(STRING,forstr2)
#define FORSTR2() CCALLSFFUN0(forstr2)
PROTOCCALLSFFUN1(STRING,forstr,STRING)
#define FORSTR(A1) CCALLSFFUN1(forstr,STRING,A1)
main() {
static char aa[] = "one";
int rrr = 333;
printf("R(rrr=%d) returns int arg. as float:%f\n",rrr,R(rrr));
printf("FORSTR(aa=%s) returns the string arg. as:%s<-end here\n",aa,FORSTR(aa));
printf("FORSTR2() returns the string constant:%s<-end here\n",FORSTR2());
}
#endif
#ifdef REV_SELECT
PROTOCCALLSFFUN1(INT,frev,INTV)
#define FREV(A1) CCALLSFFUN1(frev,INTV,A1)
PROTOCCALLSFSUB1(rev,INTV)
#define REV(A1) CCALLSFSUB1(rev,INTV,A1)
main() {
static int a[] = {1,2};
printf("REV(a[0,1]=%d,%d) returns:",a[0],a[1]);
REV(a); printf("a[0,1]=%d,%d\n",a[0],a[1]);
printf("FREV(a[0,1]=%d,%d) returns:",a[0],a[1]);
printf("%d",FREV(a)); printf(" with a[0,1]=%d,%d\n",a[0],a[1]);
}
#endif
-------------------------cut here for cfortex.f-------------------------------
C cfortex.f
C Burkhard Burow, burow%13313.hepnet at csa3.lbl.gov, U. of Toronto, 1991.
subroutine s1(b)
character*(*) b
character*(13) a
data a/'first'/
b = a
return
end
subroutine abc(a,b,c)
character*(*) b,a,c
character*(13) d
d = a
a = b
b = c
c = d
return
end
subroutine forstr1(b)
character*(*) b
character*(13) a
character*(13) forstr
data a/'firs'/
b = forstr(a)
return
end
subroutine EASY(a,b)
a = b
return
end
character*(*) function forstr(a)
character*(*) a
forstr = a
return
end
function r(i)
r = i
return
end
character*(*) function forstr2()
character*(13) a
data a/'first'/
forstr2 = a
return
end
character*(*) function ft(v, w, a)
character *(*) v(4), w(3)
print*,'FT:len(v(1 or 2 or 3 or 4)) =',len(v(1))
print*,'FT:len(w(1 or 2 or 3)) =',len(w(1))
print*,'FT:a = ',a
print*,'FT:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
print*,'FT:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4)
ft = v(1)
return
end
subroutine st(v, w, a)
character *(*) v(4), w(3)
print*,'ST:len(v(1 or 2 or 3 or 4)) =',len(v(1))
print*,'ST:len(w(1 or 2 or 3)) =',len(w(1))
print*,'ST:a = ',a
print*,'ST:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
print*,'ST:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4)
return
end
subroutine rev(a)
integer a(2),t
t = a(1)
a(1) = a(2)
a(2) = t
return
end
integer function frev(a)
integer a(2)
frev = a(1)
a(1) = a(2)
a(2) = frev
return
end
--------------------cut here for cfortran.h---------------------------------
/* cfortran.h */
/* Burkhard Burow, burow%13313.hepnet at csa3.lbl.gov, U. of Toronto, 1991. */
#ifndef sgi
/* This header file is for SGI C compilers only. */
#else
#ifndef __CFORTRAN_LOADED
#define __CFORTRAN_LOADED 1
#include <string.h>
#include <stdio.h>
/*-------------------------------------------------------------------------*/
/* UTILITIES USED WITHIN CFORTRAN */
#define COMMON_BLOCK(C) C_(C)
#define C_(A) A/**/_
static char *kill_trailing(char *s, char t)
{char *e;
for (e=s; *e; e++);
if (e!=s) {for (e--; *e==t&&e!=s; e--); *(e==s&&*e==t?e:++e)='\0';}
return s;
}
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_trailing(cstr+elem_len*i,t);
return cstr;
}
/* Convert a vector of C strings in to FORTRAN strings. */
static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
{ 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 in to C strings. */
static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
{ 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. */
fstr = (cstr += 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;
}
/* str_elem returns the length of an individual element in a vector of C
strings and requires that strv be intialized in the following way:
static char eg[][5] = {"i","am","you","no"};
S.t. the compiler places i0000
am000 (i.e the trailing 0's after each
you00 string terminator are required)
no000
into memory.
Please note that the routine requires at least 2 consecutive nonempty
string elements, or the last element must be nonempty. */
static int str_elem(char *array, char *strv, unsigned sizeof_strv)
{
unsigned len,i=0,an_element;
len=sizeof_strv;
for (; i<sizeof_strv && strv[i]==0; i++); /* find first char of an element*/
while (i<sizeof_strv) {
an_element=i;
for (; i<sizeof_strv && strv[i]!=0; i++); /* goto the end of the element */
for (; i<sizeof_strv && strv[i]==0; i++); /* find the next element */
if (len>i-an_element) len=i-an_element;
}
if (sizeof_strv%len != 0) {
fprintf(stderr,
"FATAL:CFORTRAN:str_elem: (sizeof_strv=%d)%%(%d=len)!=0 for string array %s.\
\nThe first element of the array is ->%s<-.\n\
CFORTRAN requires 2 consecutive elements or the last elemnt to be non-null.\n",
sizeof_strv,len,array,strv);
exit(1);
}
return(len);
}
/*-------------------------------------------------------------------------*/
/* UTILITIES FOR C TO CALL FORTRAN SUBROUTINES */
/* Define lookup tables for how to handle the various types of variables. */
#define VDOUBLE(A,B) double B = A;
#define VFLOAT(A,B) float B = A;
#define VINT(A,B) int B = (int)A; /* typecast for enum's sake */
#define VLOGICAL(A,B) int B = A;
#define VLONG(A,B) long B = A;
#define VSTRING(A,B)
#define VFLOATV(A,B) float *B = A;
#define VINTV(A,B) int *B = A;
#define VSTRINGV(A,B) int B;
#define VFLOATVV(A,B) float *B = A[0];
#define VINTVV(A,B) int *B = A[0];
#define VPDOUBLE(A,B)
#define VPFLOAT(A,B)
#define VPINT(A,B)
#define VPLOGICAL(A,B)
#define VPLONG(A,B)
#define VPSTRING(A,B)
#define VPSTRINGV(A,B) int B;
#define VPVOID(A,B)
#define ADOUBLE(A,B) &B
#define AFLOAT(A,B) &B
#define AINT(A,B) &B
#define ALOGICAL(A,B) &B
#define ALONG(A,B) &B
#define ASTRING(A,B) A
#define AFLOATV(A,B) B
#define AINTV(A,B) B
#define ASTRINGV(A,B) c2fstrv(A[0],A[0], \
B=str_elem("A",A[0],sizeof(A)),sizeof(A))
#define AFLOATVV(A,B) B
#define AINTVV(A,B) B
#define APDOUBLE(A,B) &A
#define APFLOAT(A,B) &A
#define APINT(A,B) (int *)&A /* typecast for enum's sake */
#define APLOGICAL(A,B) &A
#define APLONG(A,B) &A
#define APSTRING(A,B) A
#define APSTRINGV(A,B) c2fstrv(A[0],A[0], \
B=str_elem("A",A[0],sizeof(A)),sizeof(A))
#define APVOID(A,B) (void *)A
#define JDOUBLE(A,B)
#define JFLOAT(A,B)
#define JINT(A,B)
#define JLOGICAL(A,B)
#define JLONG(A,B)
#define JSTRING(A,B) ,strlen(A)
#define JFLOATV(A,B)
#define JINTV(A,B)
#define JSTRINGV(A,B) ,(B-1)
#define JFLOATVV(A,B)
#define JINTVV(A,B)
#define JPDOUBLE(A,B)
#define JPFLOAT(A,B)
#define JPINT(A,B)
#define JPLOGICAL(A,B)
#define JPLONG(A,B)
#define JPSTRING(A,B) ,strlen(A)
#define JPSTRINGV(A,B) ,(B-1)
#define JPVOID(A,B)
#define WDOUBLE(A,B)
#define WFLOAT(A,B)
#define WINT(A,B)
#define WLOGICAL(A,B)
#define WLONG(A,B)
#define WSTRING(A,B)
#define WFLOATV(A,B)
#define WINTV(A,B)
#define WSTRINGV(A,B) f2cstrv(A[0],A[0],B,sizeof(A));
#define WFLOATVV(A,B)
#define WINTVV(A,B)
#define WPDOUBLE(A,B)
#define WPFLOAT(A,B)
#define WPINT(A,B)
#define WPLOGICAL(A,B)
#define WPLONG(A,B)
#define WPSTRING(A,B) kill_trailing(A,' ');
#define WPSTRINGV(A,B) vkill_trailing(f2cstrv(A[0],A[0],B,sizeof(A)), \
B,sizeof(A),' ');
#define WPVOID(A,B)
#define PDOUBLE double *
#define PFLOAT float *
#define PINT int *
#define PLOGICAL int *
#define PLONG long *
#define PSTRING char *
#define PFLOATV float *
#define PINTV int *
#define PSTRINGV char *
#define PFLOATVV float *
#define PINTVV int *
#define PPDOUBLE double *
#define PPFLOAT float *
#define PPINT int *
#define PPLOGICAL int *
#define PPLONG long *
#define PPSTRING char *
#define PPSTRINGV char *
#define PPVOID void *
#define CCALLSFSUB0(NAME) {C_(NAME)();}
#define CCALLSFSUB1(NAME,T1,A1) \
{V/**/T1(A1,B1) C_(NAME)(A/**/T1(A1,B1) J/**/T1(A1,B1)); W/**/T1(A1,B1)}
#define CCALLSFSUB2(NAME,T1,T2,A1,A2) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) \
C_(NAME)(A/**/T1(A1,B1),A/**/T2(A2,B2) J/**/T1(A1,B1) J/**/T2(A2,B2)); \
W/**/T1(A1,B1) W/**/T2(A2,B2)}
#define CCALLSFSUB3(NAME,T1,T2,T3,A1,A2,A3) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) \
C_(NAME)(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3) \
J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3)); \
W/**/T1(A1,B1) W/**/T2(A2,B2) W/**/T3(A3,B3)}
#define CCALLSFSUB4(NAME,T1,T2,T3,T4,A1,A2,A3,A4) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) \
C_(NAME)(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3),A/**/T4(A4,B4) \
J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3) J/**/T4(A4,B4)); \
W/**/T1(A1,B1) W/**/T2(A2,B2) W/**/T3(A3,B3) W/**/T4(A4,B4)}
#define CCALLSFSUB5(NAME,T1,T2,T3,T4,T5,A1,A2,A3,A4,A5) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) V/**/T5(A5,B5) \
C_(NAME)(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3),A/**/T4(A4,B4), \
A/**/T5(A5,B5) J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3) \
J/**/T4(A4,B4) J/**/T5(A5,B5)); \
W/**/T1(A1,B1) W/**/T2(A2,B2) W/**/T3(A3,B3) W/**/T4(A4,B4) W/**/T5(A5,B5)}
#define CCALLSFSUB6(NAME,T1,T2,T3,T4,T5,T6,A1,A2,A3,A4,A5,A6) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) \
V/**/T5(A5,B5) V/**/T6(A6,B6) \
C_(NAME)(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3),A/**/T4(A4,B4), \
A/**/T5(A5,B5),A/**/T6(A6,B6) J/**/T1(A1,B1) J/**/T2(A2,B2) \
J/**/T3(A3,B3) J/**/T4(A4,B4) J/**/T5(A5,B5) J/**/T6(A6,B6)); \
W/**/T1(A1,B1) W/**/T2(A2,B2) W/**/T3(A3,B3) W/**/T4(A4,B4) \
W/**/T5(A5,B5) W/**/T6(A6,B6)}
#define CCALLSFSUB7(NAME,T1,T2,T3,T4,T5,T6,T7,A1,A2,A3,A4,A5,A6,A7) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) \
V/**/T5(A5,B5); V/**/T6(A6,B6); V/**/T7(A7,B7); \
C_(NAME)(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3),A/**/T4(A4,B4), \
A/**/T5(A5,B5),A/**/T6(A6,B6),A/**/T7(A7,B7) \
J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3) J/**/T4(A4,B4) \
J/**/T5(A5,B5) J/**/T6(A6,B6) J/**/T7(A7,B7)); \
W/**/T1(A1,B1) W/**/T2(A2,B2) W/**/T3(A3,B3) W/**/T4(A4,B4) \
W/**/T5(A5,B5) W/**/T6(A6,B6) W/**/T7(A7,B7)}
#define CCALLSFSUB8(NAME,T1,T2,T3,T4,T5,T6,T7,T8,A1,A2,A3,A4,A5,A6,A7,A8) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) \
V/**/T5(A5,B5) V/**/T6(A6,B6) V/**/T7(A7,B7) V/**/T8(A8,B8) \
C_(NAME)(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3),A/**/T4(A4,B4), \
A/**/T5(A5,B5),A/**/T6(A6,B6),A/**/T7(A7,B7),A/**/T8(A8,B8) \
J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3) J/**/T4(A4,B4) \
J/**/T5(A5,B5) J/**/T6(A6,B6) J/**/T7(A7,B7) J/**/T8(A8,B8)); \
W/**/T1(A1,B1) W/**/T2(A2,B2) W/**/T3(A3,B3) W/**/T4(A4,B4) \
W/**/T5(A5,B5) W/**/T6(A6,B6) W/**/T7(A7,B7) W/**/T8(A8,B8)}
#define PROTOCCALLSFSUB0(NAME) void C_(NAME)();
#define PROTOCCALLSFSUB1(NAME,T1) void C_(NAME)(P/**/T1, ...);
#define PROTOCCALLSFSUB2(NAME,T1,T2) void C_(NAME)(P/**/T1,P/**/T2, ...);
#define PROTOCCALLSFSUB3(NAME,T1,T2,T3) void C_(NAME)(P/**/T1,P/**/T2,P/**/T3, \
...);
#define PROTOCCALLSFSUB4(NAME,T1,T2,T3,T4) \
void C_(NAME)(P/**/T1,P/**/T2,P/**/T3,P/**/T4, ...);
#define PROTOCCALLSFSUB5(NAME,T1,T2,T3,T4,T5) \
void C_(NAME)(P/**/T1,P/**/T2,P/**/T3,P/**/T4,P/**/T5, ...);
#define PROTOCCALLSFSUB6(NAME,T1,T2,T3,T4,T5,T6) \
void C_(NAME)(P/**/T1,P/**/T2,P/**/T3,P/**/T4,P/**/T5, \
P/**/T6, ...);
#define PROTOCCALLSFSUB7(NAME,T1,T2,T3,T4,T5,T6,T7) \
void C_(NAME)(P/**/T1,P/**/T2,P/**/T3,P/**/T4,P/**/T5, \
P/**/T6,P/**/T7, ...);
#define PROTOCCALLSFSUB8(NAME,T1,T2,T3,T4,T5,T6,T7,T8) \
void C_(NAME)(P/**/T1,P/**/T2,P/**/T3,P/**/T4,P/**/T5, \
P/**/T6,P/**/T7,P/**/T8, ...);
/*-------------------------------------------------------------------------*/
/* UTILITIES FOR C TO CALL FORTRAN FUNCTIONS */
/*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN
function is called. Therefore, especially for creator's of C header files
for large FORTRAN libraries which include many functions, to reduce
compile time and object code size, it may be desirable to create
preprocessor directives to allow users to create code for only those
functions which they use. */
/* The following defines the maximum length string that a function can return.
Of course it may be undefine-d and re-define-d before individual
PROTOCCALLSFFUNn(..) as required. */
#define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE
/* The following defines a character used by CFORTRAN to flag the end of a
string coming out of a FORTRAN routine. */
#define CFORTRAN_NON_CHAR 0x7F
/* Define lookup tables for how to handle the various types of variables.
Tables used by for value returnde by - function: U,E,G,X
- arguments: U,B,D,W
Note that W... tables are from above. */
#define UDOUBLE double
#define UFLOAT float
#define UINT int
#define ULOGICAL int
#define ULONG long
#define USTRING char *
#define UFLOATV float *
#define UINTV int *
#define USTRINGV char*
#define UFLOATVV float *
#define UINTVV int *
#define UPDOUBLE double *
#define UPFLOAT float *
#define UPINT int *
#define UPLOGICAL int *
#define UPLONG long *
#define UPSTRING char *
#define UPSTRINGV char *
#define UPVOID void *
#define EDOUBLE(A) double A;
#define EFLOAT(A) float A;
#define EINT(A) int A;
#define ELOGICAL(A) int A;
#define ELONG(A) long A;
#define ESTRING(A) static char A[MAX_LEN_FORTRAN_FUNCTION_STRING+1]; \
memset(A, CFORTRAN_NON_CHAR, \
MAX_LEN_FORTRAN_FUNCTION_STRING); \
*(A+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
/* ESTRING must use static char. array which is guaranteed to exist after
function returns. */
/* N.B.i) The diff. for 0 (Zero) and >=1 arguments.
ii)That the folowing create a single unmatched '(' bracket, which
must of course be matched in the call.
iii)Commas must be handled very carefully */
#define GZDOUBLE(A,B) A=C_(B)(
#define GZFLOAT(A,B) A=C_(B)(
#define GZINT(A,B) A=C_(B)(
#define GZLOGICAL(A,B) A=C_(B)(
#define GZLONG(A,B) A=C_(B)(
#define GZSTRING(A,B) C_(B)(A,MAX_LEN_FORTRAN_FUNCTION_STRING
#define GDOUBLE(A,B) A=C_(B)(
#define GFLOAT(A,B) A=C_(B)(
#define GINT(A,B) A=C_(B)(
#define GLOGICAL(A,B) A=C_(B)(
#define GLONG(A,B) A=C_(B)(
#define GSTRING(A,B) C_(B)(A,MAX_LEN_FORTRAN_FUNCTION_STRING,
#define BDOUBLE(A) (double) A
#define BFLOAT(A) (float) A
#define BINT(A) (int) A /* typecast for enum's sake */
#define BLOGICAL(A) (int) A
#define BLONG(A) (long) A
#define BSTRING(A) (char *) A
#define BFLOATV(A) A
#define BINTV(A) A
#define BSTRINGV(A) A[0]
#define BFLOATVV(A) (A)[0]
#define BINTVV(A) (A)[0]
#define BPDOUBLE(A) (double *)&A
#define BPFLOAT(A) (float *) &A
#define BPINT(A) (int *) &A /* typecast for enum's sake */
#define BPLOGICAL(A) (int *) &A
#define BPLONG(A) (long *) &A
#define BPSTRING(A) (char *) A
#define BPSTRINGV(A) A[0]
#define BPVOID(A) (void *) A
#define SDOUBLE(A)
#define SFLOAT(A)
#define SINT(A)
#define SLOGICAL(A)
#define SLONG(A)
#define SSTRING(A)
#define SFLOATV(A)
#define SINTV(A)
#define SSTRINGV(A) ,sizeof(A)
#define SFLOATVV(A)
#define SINTVV(A)
#define SPDOUBLE(A)
#define SPFLOAT(A)
#define SPINT(A)
#define SPLOGICAL(A)
#define SPLONG(A)
#define SPSTRING(A)
#define SPSTRINGV(A) ,sizeof(A)
#define SPVOID(A)
#define HDOUBLE(A)
#define HFLOAT(A)
#define HINT(A)
#define HLOGICAL(A)
#define HLONG(A)
#define HSTRING(A)
#define HFLOATV(A)
#define HINTV(A)
#define HSTRINGV(A) ,unsigned A
#define HFLOATVV(A)
#define HINTVV(A)
#define HPDOUBLE(A)
#define HPFLOAT(A)
#define HPINT(A)
#define HPLOGICAL(A)
#define HPLONG(A)
#define HPSTRING(A)
#define HPSTRINGV(A) ,unsigned A
#define HPVOID(A)
#define XDOUBLE(A) A
#define XFLOAT(A) A
#define XINT(A) A
#define XLOGICAL(A) A
#define XLONG(A) A
#define XSTRING(A) kill_trailing(kill_trailing(A,CFORTRAN_NON_CHAR),' ')
#define CDOUBLE(A,B,C) &A
#define CFLOAT(A,B,C) &A
#define CINT(A,B,C) &A
#define CLOGICAL(A,B,C) &A
#define CLONG(A,B,C) &A
#define CSTRING(A,B,C) A
#define CFLOATV(A,B,C) A
#define CINTV(A,B,C) A
#define CSTRINGV(A,B,C) c2fstrv(A,A, B=str_elem("A",A,C),C)
#define CFLOATVV(A,B,C) A
#define CINTVV(A,B,C) A
#define CPDOUBLE(A,B,C) A
#define CPFLOAT(A,B,C) A
#define CPINT(A,B,C) A /* typecast for enum's sake */
#define CPLOGICAL(A,B,C) A
#define CPLONG(A,B,C) A
#define CPSTRING(A,B,C) A
#define CPSTRINGV(A,B,C) c2fstrv(A,A, B=str_elem("A",A,C),C)
#define CPVOID(A,B,C) A
#define YDOUBLE(A,B,C)
#define YFLOAT(A,B,C)
#define YINT(A,B,C)
#define YLOGICAL(A,B,C)
#define YLONG(A,B,C)
#define YSTRING(A,B,C)
#define YFLOATV(A,B,C)
#define YINTV(A,B,C)
#define YSTRINGV(A,B,C) f2cstrv(A,A,B,C);
#define YFLOATVV(A,B,C)
#define YINTVV(A,B,C)
#define YPDOUBLE(A,B,C)
#define YPFLOAT(A,B,C)
#define YPINT(A,B,C)
#define YPLOGICAL(A,B,C)
#define YPLONG(A,B,C)
#define YPSTRING(A,B,C) kill_trailing(A,' ');
#define YPSTRINGV(A,B,C) vkill_trailing(f2cstrv(A,A,B,C),B,C,' ');
#define YPVOID(A,B,C)
#define CFFUN(NAME) __cf__/**/NAME
#define CCALLSFFUN0(NAME) CFFUN(NAME)()
#define CCALLSFFUN1(NAME,T1,A1) CFFUN(NAME)(B/**/T1(A1) S/**/T1(A1))
#define CCALLSFFUN2(NAME,T1,T2,A1,A2) CFFUN(NAME)(B/**/T1(A1),B/**/T2(A2) \
S/**/T1(A1) S/**/T2(A2))
#define CCALLSFFUN3(NAME,T1,T2,T3,A1,A2,A3) \
CFFUN(NAME)(B/**/T1(A1),B/**/T2(A2),B/**/T3(A3) \
S/**/T1(A1) S/**/T2(A2) S/**/T3(A3))
#define CCALLSFFUN4(NAME,T1,T2,T3,T4,A1,A2,A3,A4) \
CFFUN(NAME)(B/**/T1(A1),B/**/T2(A2),B/**/T3(A3),B/**/T4(A4) \
S/**/T1(A1) S/**/T2(A2) S/**/T3(A3) S/**/T4(A4))
#define CCALLSFFUN5(NAME,T1,T2,T3,T4,T5,A1,A2,A3,A4,A5) \
CFFUN(NAME)(B/**/T1(A1),B/**/T2(A2),B/**/T3(A3),B/**/T4(A4),B/**/T5(A5) \
S/**/T1(A1) S/**/T2(A2) S/**/T3(A3) S/**/T4(A4) S/**/T5(A5))
#define CCALLSFFUN6(NAME,T1,T2,T3,T4,T5,T6,A1,A2,A3,A4,A5,A6) \
CFFUN(NAME)(B/**/T1(A1),B/**/T2(A2),B/**/T3(A3),B/**/T4(A4),B/**/T5(A5) \
B/**/T6(A6) \
S/**/T1(A1) S/**/T2(A2) S/**/T3(A3) S/**/T4(A4) S/**/T5(A5) S/**/T6(A6))
#define CCALLSFFUN7(NAME,T1,T2,T3,T4,T5,T6,T7,A1,A2,A3,A4,A5,A6,A7) \
CFFUN(NAME)(B/**/T1(A1),B/**/T2(A2),B/**/T3(A3),B/**/T4(A4),B/**/T5(A5) \
B/**/T6(A6),B/**/T7(A7) S/**/T1(A1) S/**/T2(A2) S/**/T3(A3) \
S/**/T4(A4) S/**/T5(A5) S/**/T6(A6) S/**/T7(A7))
/* N.B. Create a separate function instead of using (call function, function
value here) because in order to create the variables needed for the input
arg.'s which may be const.'s one has to do the creation within {}, but these
can never be placed within ()'s. Therefore one must create 'wrapper' functions.*/
#define PROTOCCALLSFFUN0(F,NAME) \
U/**/F NAME(); /* This is needed to correctly handle the value returned */ \
static U/**/F CFFUN(NAME)() \
{E/**/F(A0) GZ/**/F(A0,NAME)); return(X/**/F(A0));}
#define PROTOCCALLSFFUN1(F,NAME,T1) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1 H/**/T1(C1)) \
{V/**/T1(A1,B1) E/**/F(A0) G/**/F(A0,NAME)C/**/T1(A1,B1,C1) J/**/T1(A1,B1)); \
Y/**/T1(A1,B1,C1) return(X/**/F(A0));}
#define PROTOCCALLSFFUN2(F,NAME,T1,T2) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1,U/**/T2 A2 H/**/T1(C1) H/**/T2(C2)) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) E/**/F(A0) \
G/**/F(A0,NAME)C/**/T1(A1,B1,C1), C/**/T2(A2,B2,C2) J/**/T1(A1,B1) \
J/**/T2(A2,B2)); Y/**/T1(A1,B1,C1) Y/**/T2(A2,B2,C2) return(X/**/F(A0));}
#define PROTOCCALLSFFUN3(F,NAME,T1,T2,T3) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1,U/**/T2 A2,U/**/T3 A3 \
H/**/T1(C1) H/**/T2(C2) H/**/T3(C3)) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) E/**/F(A0) \
G/**/F(A0,NAME)C/**/T1(A1,B1,C1),C/**/T2(A2,B2,C2),C/**/T3(A3,B3,C3) \
J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3)); \
Y/**/T1(A1,B1,C1) Y/**/T2(A2,B2,C2) Y/**/T3(A3,B3,C3) return(X/**/F(A0));}
#define PROTOCCALLSFFUN4(F,NAME,T1,T2,T3,T4) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1,U/**/T2 A2,U/**/T3 A3,U/**/T4 A4 \
H/**/T1(C1) H/**/T2(C2) H/**/T3(C3) H/**/T4(C4)) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) E/**/F(A0) \
G/**/F(A0,NAME)C/**/T1(A1,B1,C1),C/**/T2(A2,B2,C2),C/**/T3(A3,B3,C3), \
C/**/T4(A4,B4,C4) \
J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3) J/**/T4(A4,B4))Y/**/T1(A1,B1,C1);\
Y/**/T2(A2,B2,C2) Y/**/T3(A3,B3,C3) Y/**/T4(A4,B4,C4) return(X/**/F(A0));}
#define PROTOCCALLSFFUN5(F,NAME,T1,T2,T3,T4,T5) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1,U/**/T2 A2,U/**/T3 A3,U/**/T4 A4, \
U/**/T5 A5 H/**/T1(C1) H/**/T2(C2) H/**/T3(C3) H/**/T4(C4) H/**/T5(C5)) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) V/**/T5(A5,B5) \
E/**/F(A0) G/**/F(A0,NAME)C/**/T1(A1,B1,C1),C/**/T2(A2,B2,C2), \
C/**/T3(A3,B3,C3), C/**/T4(A4,B4,C4),C/**/T5(A5,B5,C5) J/**/T1(A1,B1) \
J/**/T2(A2,B2) J/**/T3(A3,B3) J/**/T4(A4,B4) J/**/T5(A5,B5));Y/**/T1(A1,B1,C1)\
Y/**/T2(A2,B2,C2) Y/**/T3(A3,B3,C3) Y/**/T4(A4,B4,C4) Y/**/T5(A5,B5,C5) \
return(X/**/F(A0));}
#define PROTOCCALLSFFUN6(F,NAME,T1,T2,T3,T4,T5,T6) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1,U/**/T2 A2,U/**/T3 A3,U/**/T4 A4, \
U/**/T5 A5,U/**/T6 A6 H/**/T1(C1) H/**/T2(C2) \
H/**/T3(C3) H/**/T4(C4) H/**/T5(C5) H/**/T6(C6)) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) V/**/T5(A5,B5) \
V/**/T6(A6,B6) E/**/F(A0) G/**/F(A0,NAME)C/**/T1(A1,B1,C1),C/**/T2(A2,B2,C2), \
C/**/T3(A3,B3,C3),C/**/T4(A4,B4,C4),C/**/T5(A5,B5,C5),C/**/T6(A6,B6,C6) \
J/**/T1(A1,B1) J/**/T2(A2,B2) J/**/T3(A3,B3) J/**/T4(A4,B4) J/**/T5(A5,B5) \
J/**/T6(A6,B6));Y/**/T1(A1,B1,C1) Y/**/T2(A2,B2,C2) Y/**/T3(A3,B3,C3) \
Y/**/T4(A4,B4,C4) Y/**/T5(A5,B5,C5) Y/**/T6(A6,B6,C6) return(X/**/F(A0));}
#define PROTOCCALLSFFUN7(F,NAME,T1,T2,T3,T4,T5,T6,T7) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1,U/**/T2 A2,U/**/T3 A3,U/**/T4 A4, \
U/**/T5 A5,U/**/T6 A6,U/**/T7 A7 H/**/T1(C1) \
H/**/T2(C2) H/**/T3(C3) H/**/T4(C4) H/**/T5(C5) H/**/T6(C6) H/**/T7(C7)) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) V/**/T3(A3,B3) V/**/T4(A4,B4) V/**/T5(A5,B5) \
V/**/T6(A6,B6) V/**/T7(A7,B7) E/**/F(A0) G/**/F(A0,NAME)C/**/T1(A1,B1,C1), \
C/**/T2(A2,B2,C2),C/**/T3(A3,B3,C3),C/**/T4(A4,B4,C4),C/**/T5(A5,B5,C5), \
C/**/T6(A6,B6,C6),C/**/T7(A7,B7,C7) J/**/T1(A1,B1) J/**/T2(A2,B2) \
J/**/T3(A3,B3) J/**/T4(A4,B4) J/**/T5(A5,B5) J/**/T6(A6,B6) J/**/T7(A7,B7)); \
Y/**/T1(A1,B1,C1) Y/**/T2(A2,B2,C2) Y/**/T3(A3,B3,C3) Y/**/T4(A4,B4,C4) \
Y/**/T5(A5,B5,B5) Y/**/T6(A6,B6,C6) Y/**/T7(A7,B7,C7) return(X/**/F(A0));}
#endif /* __CFORTRAN_LOADED */
#endif /* This is an sgi */
More information about the Comp.sys.sgi
mailing list