burow@cernvax.cern.ch (burkhard burow) (03/28/91)
This posting releases CFORTRAN for the RISC Mips compiler.
CFORTRAN is an easy-to-use powerful bridge between C and FORTRAN. It provides
for a completely transparent, machine independant, interface between C and
FORTRAN routines. CFORTRAN's complete engine is in a single header file,
cfortran.h.
cfortran.doc, describing how to use CFORTRAN, follows.
To see a few-line CFORTRAN application cut out: cfortran.h cfortex.c cfortexf.f
from this posting. Then do:
RISC>cc -I. cfortex.c cfortexf.f -lI77 -lU77 -lF77 -o cfortex
RISC>cfortex
By changing the SELECTion ifdef of cfortex.c and recompiling you can try out
a dozen different few-line examples.
It's easy, it's fun, and you never have to worry about FORTRAN argument passing
mechanisms again.
Request for cfortran.h for VAX VMS are welcomed.
Comments, complaints, and bug reports are of course entertained.
enjoy, INTERNET: burow%13313.hepnet@csa3.lbl.gov
burkhard
------------------------cut here for cfortran.doc----------------------------
/* cfortran.doc */
/* Burkhard Burow, burow%13313.hepnet@csa3.lbl.gov, U. of Toronto, 1991. */
CFORTRAN 1.1 for RISC Mips
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.
[Port of C calls FORTRAN half only.]
- 1.1 for Mips Computer System 2.0 f77 and cc. Mar. '91.
[Runs on at least: Silicon Graphics IRIX 3.3.1
DECstations with Ultrix V4.1]
I Introduction
--------------
CFORTRAN is an easy-to-use powerful bridge between C and FORTRAN. It provides 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 cfortexf.f.
CFORTRAN was created under VAX VMS and has been fully ported to the Mips RISC
compilers.
The benefits of using CFORTRAN include:
1. Machine independant applications.
2. Identical (within syntax) calls across languages, e.g.
C FORTRAN
CALL HBOOK1(1,'pT spectrum of pi+',100,0.,5.,0.)
/* C*/
HBOOK1(1,"pT spectrum of pi+",100,0.,5.,0.);
3. Each routine need ony be set up once in its lifetime. e.g.
/* Setting up a FORTRAN routine to be called by C. Note that ID,...,VMX are
merely the names of arguments. These tags must be unique w.r.t. each other but
are arbitrary. */
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)
4. Routines, and the code calling them, can be coded naturally in the language
of choice. C routines may be coded with the natural assumption that they'll
only be called by C code. CFORTRAN does all the required work for FORTRAN
code to call C routines. Similarly CFORTRAN does all the work required for C
to call FORTRAN routines. Therefore:
- C programmers need not imbed FORTRAN argument passing mechanisms into
their code.
- FORTRAN code need not be converted into C code. i.e. The honed and
timehonored FORTRAN routines are called by C, not some new translation
from FORTRAN into C.
5. CFORTRAN is contained within a single C include file, cfortran.h.
cfortran.h IS machine/compiler dependant, versions for VAX VMS and for MIPS
RISC compilers currently exist.
6. STRINGS and VECTORS of STRINGS along with the usual simple arguments to
routines are supported as are functions returning STRINGS or numbers.
7. CFORTRAN requires each routine to be exported to be explicitly set up. While
this need usually only be done once in a header file it would be best if
applications were required to do no work at all in order to cross languages.
CFORTRAN's simple syntax could be a convinient back-end for a program which
would export FORTRAN or C routines directly from the source code.
-----
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 using CFORTRAN'd routines are machine independant.
II Using CFORTRAN
-----------------
The user is asked to look at the source files cfortex.c and cfortexf.f for
clarification by example.
Note: CFORTRAN (ab)uses the null comment, /**/, kludge for the ANSI C
preprocessor concatenation, ##, operator. In MIPS C 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.
Note: At the moment only vectors of fixed length strings are supported in C. I
know how and hope to support vectors of pointers to strings in the near future.
Note: For those who wish to use CFORTRAN in large applications.
This release is intended to make it easy to get applications up and running.
This implies that applications are not as efficient as they could be:
- The current mechanism is very inefficient if a single header file is used to
describe a large library of FORTRAN functions. Code for a static wrapper fn.
is generated in each piece of C source code for each FORTRAN function
specified with the CCALLSFFUNn statement, irrespective of whether or not the
function is ever called. I have several ideas for how code for these wrappers
could be created, compiled and linked only once instead of once for each
piece of source code.
- Code for several static utility routines internal to CFORTRAN is placed into
any source code which #include's cfortran.h. These routines should be in a
library.
- The FORTRAN calls C half of the package could be split from the C calls
FORTRAN half.
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:
Note that each of the following two statements to export a C routine to FORTRAN
create FORTRAN 'wrappers', written in C, which must be compiled and linked
along with the original C routines and with the FORTRAN calling code.
FCALLSCSUBn(routine_name, argtype_1, ..., argtype_n)
or
FCALLSCFUNn(routine_type, routine_name, argtype_1, ..., argtype_n)
Where:
'n' = 0->7 (easily expanded to >7) stands for the number of arguments to the
routine.
routine_name = the FORTRAN name of the routine (IN lowercase LETTERS).
routine_type = the type of argument returned by C 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
= DOUBLE, FLOAT, INT, LOGICAL, LONG, STRING, STRINGV.
For arrays or for routines changing the values of any of their
arguments; the C routines expect pointers to these arguments,
so the keywords are prepended by a 'P'.
= PDOUBLE, PFLOAT, PINT, PLOGICAL, PLONG, PSTRING, PSTRINGV,
PVOID.
The keyword PVOID is a generic form of the nonSTRING types.
STRINGV refers to vector of strings.
(P)STRINGV: CFORTRAN cannot convert the FORTRAN vector of STRINGS to the
required C vector of STRINGS without explicitly knowing the number of elements
in the vector. The application must do one of the following for each (P)STRINGV
argument in a routine before that routine's FCALLSCFUNn/SUBn is called:
#define routine_name_STRV_Ai NUM_ELEMS(j)
or
#define routine_name_STRV_Ai NUM_ELEM_ARG(k)
or
#define routine_name_STRV_Ai TERM_CHARS(l,m)
where: routine_name is as above.
i [i=1->n.] specifies the argument number of a STRING VECTOR.
j would specify a fixed number of elements.
k [k=1->n. k!=i] would specify an integer argument which specifies the
number of elements.
l [char] the terminating character at the beginning of an
element, indicating to cfortran that the preceeding
elements in the vector are the valid ones.
m [m=1-...] the number of terminating characters required to appear
at the beginning of the terminating string element.
Note that the terminating element is NOT possed on to
the C routine.
e.g.
CFORTRAN will pass on all elements, in the 1st and only argument to the C
routine ce, of the STRING VECTOR until, but not including, the first string
element beginning with 2 blank, ' ', characters.
#define ce_STRV_A1 TERM_CHARS(' ',2)
FCALLSCSUB1(ce,STRINGV)
The lists of types are not neccessarily complete. It is easy for CFORTRAN to
handle a new type not in this list.
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 A COMMERCIAL PRODUCT, 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), DECstations and Mips are registered trademarks.
/* end: cfortran.doc */
-------------cut here for cfortran.h -----------------------------------------
/* cfortran.h */
/* Burkhard Burow, burow%13313.hepnet@csa3.lbl.gov, U. of Toronto, 1991. */
#ifndef mips
/* This header file is for MIPS C and FORTRAN 2.0 compilers. */
#else
#ifndef __CFORTRAN_LOADED
#define __CFORTRAN_LOADED 1
#include <string.h>
#include <stdio.h>
#include <stdlib.h>
/*-------------------------------------------------------------------------*/
/* UTILITIES USED WITHIN CFORTRAN */
#define MIN(A,B) ((A)<(B)?(A):(B))
#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 into 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 into 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. */
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;
}
/* 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;
}
#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
static int num_elem(char *strv, unsigned elem_len, int term_char,
int num_term_char)
/* 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_char term_char characters, so that this routine can determine how
many elements are in the vector. */
{
unsigned num,i;
if (num_term_char == _NUM_ELEMS || num_term_char == _NUM_ELEM_ARG)
return term_char;
if (num_term_char <=0) num_term_char = elem_len;
for (num=0; ; num++) {
for (i=0; i<num_term_char && *strv==term_char; i++,strv++);
if (i==num_term_char) break;
else strv += elem_len-i;
}
return num;
}
/*-------------------------------------------------------------------------*/
/* UTILITIES FOR C TO CALL FORTRAN SUBROUTINES */
/* Define lookup tables for how to handle the various types of variables. */
#define VCF(TN,I) V/**/TN(A/**/I,B/**/I)
#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) ASTRINGV(A,B)
#define APVOID(A,B) (void *)A
#define JCF(TN,I) J/**/TN(A/**/I,B/**/I)
#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 CCALLSFSUB9(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
{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) V/**/T9(A9,B9) \
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), \
A/**/T9(A9,B9) 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) J/**/T9(A9,B9)); \
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) W/**/T9(A9,B9)}
#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, ...);
#define PROTOCCALLSFSUB9(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
void C_(NAME)(P/**/T1,P/**/T2,P/**/T3,P/**/T4,P/**/T5, \
P/**/T6,P/**/T7,P/**/T8,P/**/T9, ...);
/*-------------------------------------------------------------------------*/
/* 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 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 UVOID void *
#define EDOUBLE double A0;
#define EFLOAT float A0;
#define EINT int A0;
#define ELOGICAL int A0;
#define ELONG long A0;
#define ESTRING static char A0[MAX_LEN_FORTRAN_FUNCTION_STRING+1]; \
memset(A0, CFORTRAN_NON_CHAR, \
MAX_LEN_FORTRAN_FUNCTION_STRING); \
*(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
/* ESTRING uses static char. array which exists after function returns. */
/* N.B.i) The diff. for 0 (Zero) and >=1 arguments.
ii)That the folowing create a single unmatched '(' bracket.
iii)Commas must be handled very carefully */
#define GZDOUBLE(B) A0=C_(B)(
#define GZFLOAT(B) A0=C_(B)(
#define GZINT(B) A0=C_(B)(
#define GZLOGICAL(B) A0=C_(B)(
#define GZLONG(B) A0=C_(B)(
#define GZSTRING(B) C_(B)(A0,MAX_LEN_FORTRAN_FUNCTION_STRING
#define GDOUBLE(B) A0=C_(B)(
#define GFLOAT(B) A0=C_(B)(
#define GINT(B) A0=C_(B)(
#define GLOGICAL(B) A0=C_(B)(
#define GLONG(B) A0=C_(B)(
#define GSTRING(B) GZSTRING(B),
#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 return A0;
#define XFLOAT return A0;
#define XINT return A0;
#define XLOGICAL return A0;
#define XLONG return A0;
#define XSTRING return kill_trailing( \
kill_trailing(A0,CFORTRAN_NON_CHAR),' ');
#define CCF(TN,I) C/**/TN(A/**/I,B/**/I,C/**/I)
#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) CSTRINGV(A,B,C)
#define CPVOID(A,B,C) A
#define YCF(TN,I) Y/**/TN(A/**/I,B/**/I,C/**/I)
#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 GZ/**/F(NAME)); X/**/F}
#define PROTOCCALLSFFUN1(F,NAME,T1) \
U/**/F C_(NAME)(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1 H/**/T1(C1)) \
{VCF(T1,1) E/**/F G/**/F(NAME)CCF(T1,1) JCF(T1,1)); YCF(T1,1) X/**/F}
#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)) \
{VCF(T1,1) VCF(T2,2) E/**/F G/**/F(NAME)CCF(T1,1) CCF(T2,2) \
JCF(T1,1) JCF(T2,2)); YCF(T1,1) YCF(T2,2) X/**/F}
#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)) \
{VCF(T1,1) VCF(T2,2) VCF(T3,3) E/**/F \
G/**/F(NAME)CCF(T1,1) CCF(T2,2) CCF(T3,3) JCF(T1,1) JCF(T2,2) JCF(T3,3)); \
YCF(T1,1) YCF(T2,2) YCF(T3,3) X/**/F}
#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)) \
{VCF(T1,1) VCF(T2,2) VCF(T3,3) VCF(T4,4) E/**/F \
G/**/F(NAME)CCF(T1,1) CCF(T2,2) CCF(T3,3) CCF(T4,4) JCF(T1,1) JCF(T2,2) \
JCF(T3,3) JCF(T4,4)); YCF(T1,1) YCF(T2,2) YCF(T3,3) YCF(T4,4) X/**/F}
#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)) \
{VCF(T1,1) VCF(T2,2) VCF(T3,3) VCF(T4,4) VCF(T5,5) E/**/F \
G/**/F(NAME)CCF(T1,1) CCF(T2,2) CCF(T3,3) CCF(T4,4) CCF(T5,5) \
JCF(T1,1) JCF(T2,2) JCF(T3,3) JCF(T4,4) JCF(T5,5)); \
YCF(T1,1) YCF(T2,2) YCF(T3,3) YCF(T4,4) YCF(T5,5) X/**/F}
#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)) \
{VCF(T1,1) VCF(T2,2) VCF(T3,3) VCF(T4,4) VCF(T5,5) VCF(T6,6) E/**/F \
G/**/F(NAME)CCF(T1,1) CCF(T2,2) CCF(T3,3) CCF(T4,4) CCF(T5,5) CCF(T6,6) \
JCF(T1,1) JCF(T2,2) JCF(T3,3) JCF(T4,4) JCF(T5,5) JCF(T6,6)); \
YCF(T1,1) YCF(T2,2) YCF(T3,3) YCF(T4,4) YCF(T5,5) YCF(T6,6) X/**/F}
#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)) \
{VCF(T1,1) VCF(T2,2) VCF(T3,3) VCF(T4,4) VCF(T5,5) VCF(T6,6) VCF(T7,7) E/**/F \
G/**/F(NAME)CCF(T1,1)CCF(T2,2)CCF(T3,3)CCF(T4,4)CCF(T5,5) CCF(T6,6) CCF(T7,7) \
JCF(T1,1) JCF(T2,2) JCF(T3,3) JCF(T4,4) JCF(T5,5) JCF(T6,6) JCF(T7,7)); \
YCF(T1,1) YCF(T2,2) YCF(T3,3) YCF(T4,4) YCF(T5,5) YCF(T6,6) YCF(T7,7) X/**/F}
/*-------------------------------------------------------------------------*/
/* UTILITIES FOR FORTRAN TO CALL C ROUTINES */
/* Define lookup tables for how to handle the various types of variables. */
#define FZDOUBLE(A) double A(
#define FZFLOAT(A) float A(
#define FZINT(A) int A(
#define FZLOGICAL(A) int A(
#define FZLONG(A) long A(
#define FZSTRING(A) void A(char *AS, unsigned D0
#define FZVOID(A) void A(
#define FDOUBLE(A) double A(
#define FFLOAT(A) float A(
#define FINT(A) int A(
#define FLOGICAL(A) int A(
#define FLONG(A) long A(
#define FSTRING(A) FZSTRING(A),
#define FVOID(A) void A(
#define DDOUBLE(A)
#define DFLOAT(A)
#define DINT(A)
#define DLOGICAL(A)
#define DLONG(A)
#define DSTRING(A) ,unsigned A
#define DFLOATV(A)
#define DINTV(A)
#define DSTRINGV(A) ,unsigned A
#define DFLOATVV(A)
#define DINTVV(A)
#define DPDOUBLE(A)
#define DPFLOAT(A)
#define DPINT(A)
#define DPLOGICAL(A)
#define DPLONG(A)
#define DPSTRING(A) ,unsigned A
#define DPSTRINGV(A) ,unsigned A
#define DPVOID(A)
#define QDOUBLE(A)
#define QFLOAT(A)
#define QINT(A)
#define QLOGICAL(A)
#define QLONG(A)
#define QSTRING(A) char *A;
#define QFLOATV(A)
#define QINTV(A)
#define QSTRINGV(A) char *A; unsigned int A/**/N;
#define QFLOATVV(A)
#define QINTVV(A)
#define QPDOUBLE(A)
#define QPFLOAT(A)
#define QPINT(A)
#define QPLOGICAL(A)
#define QPLONG(A)
#define QPSTRING(A) char *A;
#define QPSTRINGV(A) QSTRINGV(A)
#define QPVOID(A)
#define LDOUBLE A0=
#define LFLOAT A0=
#define LINT A0=
#define LLOGICAL A0=
#define LLONG A0=
#define LSTRING A0=
#define LVOID
#define TCF(NAME,TN,I) T/**/TN(NAME,A/**/I,B/**/I,D/**/I)
#define TDOUBLE(M,A,B,D) *A
#define TFLOAT(M,A,B,D) *A
#define TINT(M,A,B,D) *A
#define TLOGICAL(M,A,B,D) *A
#define TLONG(M,A,B,D) *A
#define TSTRING(M,A,B,D) (memcpy(B=malloc(D+1),A,D),B[D]='\0', \
kill_trailing(B,' '))
#define TFLOATV(M,A,B,D) A
#define TINTV(M,A,B,D) A
#define TSTRINGV(M,A,B,D) (B/**/N=num_elem(A,D,M/**/_STRV_/**/A), \
(void *)f2cstrv(A,B=malloc(B/**/N*(D+1)),D+1, \
B/**/N*(D+1)))
#define TFLOATVV(M,A,B,D) A
#define TINTVV(M,A,B,D) A
#define TPDOUBLE(M,A,B,D) A
#define TPFLOAT(M,A,B,D) A
#define TPINT(M,A,B,D) A
#define TPLOGICAL(M,A,B,D) A
#define TPLONG(M,A,B,D) A
#define TPSTRING(M,A,B,D) TSTRING(M,A,B,D)
#define TPSTRINGV(M,A,B,D) TSTRINGV(M,A,B,D)
#define TPVOID(M,A,B,D) A
#define KDOUBLE
#define KFLOAT
#define KINT
#define KLOGICAL
#define KLONG
#define KSTRING memcpy(AS,A0, MIN(D0,(A0==NULL?0:strlen(A0))) ); \
D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \
' ', D0-(A0==NULL?0:strlen(A0))):0;
/* The above line copies the string into the position provided by the caller. */
#define KVOID
#define RCF(TN,I) R/**/TN(A/**/I,B/**/I,D/**/I)
#define RDOUBLE(A,B,D)
#define RFLOAT(A,B,D)
#define RINT(A,B,D)
#define RLOGICAL(A,B,D)
#define RLONG(A,B,D)
#define RSTRING(A,B,D) free(B);
#define RFLOATV(A,B,D)
#define RINTV(A,B,D)
#define RSTRINGV(A,B,D) free(B);
#define RFLOATVV(A,B,D)
#define RINTVV(A,B,D)
#define RPDOUBLE(A,B,D)
#define RPFLOAT(A,B,D)
#define RPINT(A,B,D)
#define RPLOGICAL(A,B,D)
#define RPLONG(A,B,D)
#define RPSTRING(A,B,D) memcpy(A,B,MIN(strlen(B),D)), \
(D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), \
free(B);
#define RPSTRINGV(A,B,D) c2fstrv(B,A,D+1,(D+1)*B/**/N), free(B);
#define RPVOID(A,B,D)
#define IDOUBLE return A0;
#define IFLOAT return A0;
#define IINT return A0;
#define ILOGICAL return A0;
#define ILONG return A0;
#define ISTRING return;
#define IVOID return;
#define FCALLSCSUB0(NAME) FCALLSCFUN0(VOID,NAME)
#define FCALLSCSUB1(NAME,T1) FCALLSCFUN1(VOID,NAME,T1)
#define FCALLSCSUB2(NAME,T1,T2) FCALLSCFUN2(VOID,NAME,T1,T2)
#define FCALLSCSUB3(NAME,T1,T2,T3) FCALLSCFUN3(VOID,NAME,T1,T2,T3)
#define FCALLSCSUB4(NAME,T1,T2,T3,T4) FCALLSCFUN4(VOID,NAME,T1,T2,T3,T4)
#define FCALLSCSUB5(NAME,T1,T2,T3,T4,T5) FCALLSCFUN5(VOID,NAME,T1,T2,T3,T4,T5)
#define FCALLSCSUB6(NAME,T1,T2,T3,T4,T5,T6) \
FCALLSCFUN6(VOID,NAME,T1,T2,T3,T4,T5,T6)
#define FCALLSCSUB7(NAME,T1,T2,T3,T4,T5,T6,T7) \
FCALLSCFUN7(VOID,NAME,T1,T2,T3,T4,T5,T6,T7)
#define FCALLSCSUB8(NAME,T1,T2,T3,T4,T5,T6,T7,T8) \
FCALLSCFUN8(VOID,NAME,T1,T2,T3,T4,T5,T6,T7,T8)
#define FCALLSCSUB9(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
FCALLSCFUN9(VOID,NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9)
#define FCALLSCFUN0(T0,NAME) \
FZ/**/T0(C_(NAME))) \
{U/**/T0 A0; L/**/T0 NAME(); K/**/T0 I/**/T0}
#define FCALLSCFUN1(T0,NAME,T1) \
F/**/T0(C_(NAME))P/**/T1 A1 D/**/T1(D1)) {U/**/T0 A0; Q/**/T1(B1) \
L/**/T0 NAME(TCF(NAME,T1,1)); K/**/T0 RCF(T1,1) I/**/T0}
#define FCALLSCFUN2(T0,NAME,T1,T2) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2 D/**/T1(D1) D/**/T2(D2)) \
{U/**/T0 A0; Q/**/T1(B1) Q/**/T2(B2) \
L/**/T0 NAME(TCF(NAME,T1,1),TCF(NAME,T2,2));K/**/T0 RCF(T1,1)RCF(T2,2) I/**/T0}
#define FCALLSCFUN3(T0,NAME,T1,T2,T3) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2,P/**/T3 A3 D/**/T1(D1) D/**/T2(D2) \
D/**/T3(D3)) {U/**/T0 A0; Q/**/T1(B1) Q/**/T2(B2) Q/**/T3(B3) \
L/**/T0 NAME(TCF(NAME,T1,1),TCF(NAME,T2,2),TCF(NAME,T3,3)); \
K/**/T0 RCF(T1,1) RCF(T2,2) RCF(T3,3) I/**/T0}
#define FCALLSCFUN4(T0,NAME,T1,T2,T3,T4) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2,P/**/T3 A3,P/**/T4 A4 D/**/T1(D1) \
D/**/T2(D2) D/**/T3(D3) D/**/T4(D4)) {U/**/T0 A0; Q/**/T1(B1) Q/**/T2(B2) \
Q/**/T3(B3) Q/**/T4(B4) L/**/T0 NAME(TCF(NAME,T1,1),TCF(NAME,T2,2), \
TCF(NAME,T3,3),TCF(NAME,T4,4)); K/**/T0 RCF(T1,1)RCF(T2,2) RCF(T3,3) RCF(T4,4)\
I/**/T0}
#define FCALLSCFUN5(T0,NAME,T1,T2,T3,T4,T5) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2,P/**/T3 A3,P/**/T4 A4,P/**/T5 A5 \
D/**/T1(D1) D/**/T2(D2) D/**/T3(D3) D/**/T4(D4) D/**/T5(D5)) {U/**/T0 A0; \
Q/**/T1(B1) Q/**/T2(B2) Q/**/T3(B3) Q/**/T4(B4) Q/**/T5(B5) L/**/T0 \
NAME(TCF(NAME,T1,1),TCF(NAME,T2,2),TCF(NAME,T3,3),TCF(NAME,T4,4), \
TCF(NAME,T5,5)); K/**/T0 RCF(T1,1)RCF(T2,2)RCF(T3,3)RCF(T4,4)RCF(T5,5) I/**/T0}
#define FCALLSCFUN6(T0,NAME,T1,T2,T3,T4,T5,T6) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2,P/**/T3 A3,P/**/T4 A4,P/**/T5 A5, \
P/**/T6 A6 D/**/T1(D1) D/**/T2(D2) D/**/T3(D3) D/**/T4(D4) D/**/T5(D5) \
D/**/T6(D6)) {U/**/T0 A0; Q/**/T1(B1) Q/**/T2(B2) Q/**/T3(B3) Q/**/T4(B4) \
Q/**/T5(B5) Q/**/T6(B6) L/**/T0 NAME(TCF(NAME,T1,1),TCF(NAME,T2,2), \
TCF(NAME,T3,3),TCF(NAME,T4,4),TCF(NAME,T5,5),TCF(NAME,T6,6)); K/**/T0 \
RCF(T1,1) RCF(T2,2) RCF(T3,3) RCF(T4,4) RCF(T5,5) RCF(T6,6) I/**/T0}
#define FCALLSCFUN7(T0,NAME,T1,T2,T3,T4,T5,T6,T7) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2,P/**/T3 A3,P/**/T4 A4,P/**/T5 A5, \
P/**/T6 A6 P/**/T7 A7 D/**/T1(D1) D/**/T2(D2) D/**/T3(D3) D/**/T4(D4) \
D/**/T5(D5) D/**/T6(D6) D/**/T7(D7)) {U/**/T0 A0; Q/**/T1(B1) Q/**/T2(B2) \
Q/**/T3(B3) Q/**/T4(B4) Q/**/T5(B5) Q/**/T6(B6) Q/**/T7(B7) L/**/T0 \
NAME(TCF(NAME,T1,1),TCF(NAME,T2,2),TCF(NAME,T3,3),TCF(NAME,T4,4), \
TCF(NAME,T5,5),TCF(NAME,T6,6),TCF(NAME,T7,7)); K/**/T0 \
RCF(T1,1) RCF(T2,2) RCF(T3,3) RCF(T4,4) RCF(T5,5) RCF(T6,6) RCF(T7,7) I/**/T0}
#define FCALLSCFUN8(T0,NAME,T1,T2,T3,T4,T5,T6,T7,T8) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2,P/**/T3 A3,P/**/T4 A4,P/**/T5 A5, \
P/**/T6 A6 P/**/T7 A7 P/**/T8 A8 D/**/T1(D1) D/**/T2(D2) D/**/T3(D3) \
D/**/T4(D4) D/**/T5(D5) D/**/T6(D6) D/**/T7(D7) D/**/T8(D8)) {U/**/T0 A0; \
Q/**/T1(B1) Q/**/T2(B2) Q/**/T3(B3) Q/**/T4(B4) Q/**/T5(B5) Q/**/T6(B6) \
Q/**/T7(B7) Q/**/T8(B8) L/**/T0 NAME(TCF(NAME,T1,1),TCF(NAME,T2,2), \
TCF(NAME,T3,3),TCF(NAME,T4,4),TCF(NAME,T5,5),TCF(NAME,T6,6),TCF(NAME,T7,7), \
TCF(NAME,T8,8)); K/**/T0 RCF(T1,1) RCF(T2,2) RCF(T3,3) RCF(T4,4) RCF(T5,5) \
RCF(T6,6) RCF(T7,7) RCF(T8,8) I/**/T0}
#define FCALLSCFUN9(T0,NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
F/**/T0(C_(NAME))P/**/T1 A1,P/**/T2 A2,P/**/T3 A3,P/**/T4 A4,P/**/T5 A5, \
P/**/T6 A6 P/**/T7 A7 P/**/T8 A8 P/**/T9 A9 D/**/T1(D1) D/**/T2(D2) \
D/**/T3(D3) D/**/T4(D4) D/**/T5(D5) D/**/T6(D6) D/**/T7(D7) D/**/T8(D8) \
D/**/T8(D8) D/**/T9(D9)) {U/**/T0 A0; Q/**/T1(B1) Q/**/T2(B2) Q/**/T3(B3) \
Q/**/T4(B4) Q/**/T5(B5) Q/**/T6(B6) Q/**/T7(B7) Q/**/T8(B8) Q/**/T9(B9) \
L/**/T0 NAME(TCF(NAME,T1,1),TCF(NAME,T2,2),TCF(NAME,T3,3),TCF(NAME,T4,4), \
TCF(NAME,T5,5),TCF(NAME,T6,6),TCF(NAME,T7,7),TCF(NAME,T8,8),TCF(NAME,T9,9)); \
K/**/T0 RCF(T1,1) RCF(T2,2) RCF(T3,3) RCF(T4,4) RCF(T5,5) \
RCF(T6,6) RCF(T7,7) RCF(T8,8) RCF(T9,9) I/**/T0}
#endif /* __CFORTRAN_LOADED */
#endif /* This for MIPS compilers. */
----------------cut here for cfortex.c-----------------------------------------
/* cfortex.c */
/* Burkhard Burow, burow%13313.hepnet@csa3.lbl.gov, U. of Toronto, 1991. */
#include <stdio.h>
#include "cfortran.h"
#define FJ_SELECT 1 /* To see the various examples select one of:
EASY_SELECT, ST_SELECT, FT_SELECT S1_SELECT ABC_SELECT R_SELECT,
REV_SELECT, F0_SELECT, FA_SELECT, FB_SELECT, FC_SELECT, FD_SELECT,
FE_SELECT, FF_SELECT, FG_SELECT, FH_SELECT, FI_SELECT, FJ_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
/* The following functions are called by FORTRAN functions, as shown by the
remaining examples. */
void exist() {printf("EXIST: was called.\n");}
FCALLSCSUB0(exist)
void ca(int i) {printf("CA: had integer argument:%d.\n",i);}
FCALLSCSUB1(ca,INT)
void cb(int *i) {
printf("CB: had pointer argument to integer:%d.\n",*i); *i*=2;}
FCALLSCSUB1(cb,PINT)
void cc(char *s) {printf("CC: had string argument:%s.\n",s);}
FCALLSCSUB1(cc,STRING)
void cd(char *s)
{printf("CD: had string argument:%s.\n",s); strcpy(s,"to you 12345678");}
FCALLSCSUB1(cd,PSTRING)
void ce(char v[][5])
{printf("CE: had string vector argument:%s,%s,%s.\n",v[0],v[1],v[2]);}
#define ce_STRV_A1 TERM_CHARS(' ',1)
FCALLSCSUB1(ce,STRINGV)
void cf(char v[][5], int n)
{int i;
printf("CF: had %d string vector argument:",n);
for (i=0; i<n-1; i++) printf("%s,",v[i]);
printf("%s.\n",v[i]);
}
#define cf_STRV_A1 NUM_ELEM_ARG(2)
FCALLSCSUB2(cf,STRINGV,INT)
int cg() {return 1;}
FCALLSCFUN0(INT,cg)
char *ch() {return "hello";}
FCALLSCFUN0(STRING,ch)
char *ci(char v[][5]) {return v[3];}
#define ci_STRV_A1 NUM_ELEMS(6)
FCALLSCFUN1(STRING,ci,STRINGV)
char *cj(int v) {printf("CJ:v=%d\n",v);return "hello";}
FCALLSCFUN1(STRING,cj,INT)
#ifdef F0_SELECT
PROTOCCALLSFSUB0(fexist)
#define FEXIST() CCALLSFSUB0(fexist)
main() {FEXIST();}
#endif
#ifdef FA_SELECT
PROTOCCALLSFSUB1(fa,INT)
#define FA(A1) CCALLSFSUB1(fa,INT,A1)
main() {FA(1234);}
#endif
#ifdef FB_SELECT
PROTOCCALLSFSUB1(fb,PINT)
#define FB(A1) CCALLSFSUB1(fb,PINT,A1)
main()
{int i,ii; i=ii=1234;
FB(ii); printf("MAIN: FB(i=%d) returns with i=%d.\n",i,ii);}
#endif
#ifdef FC_SELECT
PROTOCCALLSFSUB1(fc,STRING)
#define FC(A1) CCALLSFSUB1(fc,STRING,A1)
main() {FC("hello");}
#endif
#ifdef FD_SELECT
PROTOCCALLSFSUB1(fd,PSTRING)
#define FD(A1) CCALLSFSUB1(fd,PSTRING,A1)
main()
{static char i[] = "happy "; static char ii[] = "happy ";
FD(ii); printf("MAIN: FD(i=%s) returns with i=%s.\n",i,ii);}
#endif
#ifdef FE_SELECT
PROTOCCALLSFSUB1(fe,STRINGV)
#define FE(A1) CCALLSFSUB1(fe,STRINGV,A1)
main()
{static char v[][5] = {"0000", "1", "22", ""}; FE(v);}
#endif
#ifdef FF_SELECT
PROTOCCALLSFSUB2(ff,STRINGV,INT)
#define FF(A1,A2) CCALLSFSUB2(ff,STRINGV,INT, A1,A2)
main()
{static char v[][5] = {"0000", "1", "22", "", "8", "9"};
FF(v,sizeof(v)/sizeof v[0]);}
#endif
#ifdef FG_SELECT
PROTOCCALLSFFUN0(INT,fg)
#define FG() CCALLSFFUN0(fg)
main()
{printf("FG() returns %d.\n",FG());}
#endif
#ifdef FH_SELECT
PROTOCCALLSFFUN0(STRING,fh)
#define FH() CCALLSFFUN0(fh)
main()
{printf("FH() returns %s.\n",FH());}
#endif
#ifdef FI_SELECT
PROTOCCALLSFFUN1(STRING,fi,STRINGV)
#define FI(A1) CCALLSFFUN1(fi,STRINGV,A1)
main()
{static char v[][5] = {"0000", "1", "22", "333", "8", "9"};
printf("FI(v) returns %s.\n",FI(v));}
#endif
#ifdef FJ_SELECT
PROTOCCALLSFFUN1(STRING,fj,INT)
#define FJ(A1) CCALLSFFUN1(fj,INT,A1)
main()
{ printf("FJ(2) returns %s.\n",FJ(2));}
#endif
-----------------cut here for cfortexf.f---------------------------------------
C cfortexf.f
C Burkhard Burow, University of Toronto, July 1990.
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
subroutine fexist()
print*,'FEXIST: was called'
call exist()
return
end
subroutine fa(i)
integer i
print*,'FA: integer argument =',i
call ca(i)
return
end
subroutine fb(i)
integer i
print*,'FB: integer argument =',i
i = i*2
call cb(i)
return
end
subroutine fc(b)
character*(*) b
print*,'FC: string argument =',b
call cc(b)
return
end
subroutine fd(b)
character*(*) b
character*(13) a
data a/'birthday'/
b = a
call cd(b)
return
end
subroutine fe(v)
character*(*) v(4)
print*,'FE:len(v(1 or 2 or 3 or 4)) =',len(v(1))
print*,'FE:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
call ce(v)
return
end
subroutine ff(v,n)
character*(*) v(4)
print*,'FE:len(v(1 or 2 or 3 or 4)) =',len(v(1))
print*,'FE:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
print*,'FE:n =',n
call cf(v,n)
return
end
integer function fg()
integer cg
fg = cg()
return
end
character*(*) function fh()
character*200 ch
fh = ch()
return
end
character*(*) function fi(v)
character*(*) v(6)
character*200 ci
fi = ci(v)
return
end
character*(*) function fj(v)
integer v
character*200 cj
print*,'FJ:v =',v
fj = cj(v)
return
end
--------------------end or CFORTRAN release------------------------------------