burow@cernvax.cern.ch (burkhard burow) (05/17/91)
This posting is the latest release of CFORTRAN. It makes C<->FORTRAN easy.
The application interface has not changed. The internals have been improved.
IBM RS/6000 - The Mips version works, we now call this the unix version.
- Q: Is there a predefined macro to id the RS/6000?
VMS - The string handling machinery has been simplified and now parallels the
unix version very closely.
- LIB$.... from C will never be easier. descrip.h will no longer haunt you.
- %CC-I-PARAMNOTUSED is the only reason a separate cfortran.h file has to
exist for VMS. Any chance for a #pragma to turn this thing off?
Sun - The unix version should run out of the box on any near ANSI compiler.
Unfortunately the SPARCstation I found had only K&R I C, so I couldn't
try it out.
CERN, the European High Energy Physics Lab, has announced that it would like to
release its FORTRAN Program Library to C users via CFORTRAN. So CFORTRAN may
someday soon be well supported. If you've got nothing to do on Sunday, and
you'd like to sharpen your preprocessing skills and own/have an account(s) on
Apollo SR10, HP 9000, Cray, IBM mainframe, Convex, Next, ....
machines, cfortran.h makes an interesting 'easy' port. Or if you wait a while,
CFORTRAN will make its way to you. [Funny how it's easier for me to get
accounts on these machines than it is to get a FORTRAN manual for them. :-)]
Appended is cfortran.doc, cfortran_unix.h, cfortran_vms.h, cfortest.c,
cfortex.for.
tschuess,
burkhard
--------------cut for cfortran.doc----------------------------------
/* cfortran.doc */
/* Burkhard Burow, burow@vxdesy.desy.de, U. of Toronto, 1991. */
CFORTRAN 1.2 for UNIX Machines and for VAX VMS
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]
- 1.2 Internals are simpler, smaller, faster, stronger. May '91.
Mips version works on IBM RS/6000, this is now called the unix version.
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 cfortest.c and
cfortex.f/or. [cfortex.for under VMS, cfortex.f under UNIX.]
Note that there exist 2 versions of cfortran.h:
cfortran_vms.h - for VAX VMS
cfortran_unix.h - for UNIX Machines
The appropriate one of these two files will have to be renamed to cfortran.h in
order for CFORTRAN to work on your system.
To run the example do the following:
RS/6000> mv cfortran_unix.h cfortran.h
RS/6000> cc -Drs6000 -c cfortest.c && xlf -o cfortest cfortest.o cfortex.f
RS/6000> cfortest
or
MIPS> mv cfortran_unix.h cfortran.h
MIPS> cc -o cfortest cfortest.c cfortex.f -lI77 -lU77 -lF77
MIPS> cfortest
or
VMS> rena cfortran_vms.h cfortran.h
VMS> define lnk$library sys$library:vaxcrtl
VMS> cc cfortest.c
VMS> fortran cfortex.for
VMS> link/exec=cfortest cfortest,cfortex
VMS> run cfortest
By changing the SELECTion ifdef of cfortest.c and recompiling you can try out
a dozen different few-line examples.
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, weighing
in at less than 900 lines.
cfortran.h IS machine/compiler dependant, versions for VAX VMS and for the
UNIX machines, IBM RS/6000 and those using MIPS RISC, currently exist. The
UNIX version is probably easily ported to many other UNIX platforms.
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 1 - 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.
-----
Example 2 - Many VMS System calls are most easily called from FORTRAN, but
CFORTRAN now gives you that ease in C.
#include "cfortran.h"
PROTOCCALLSFSUB3(lib$spawn, STRING, STRING, STRING)
#define LIB$SPAWN(command, input_file, output_file) \
CCALLSFSUB3(lib$spawn, STRING, STRING, STRING, command, input_file, output)
main ()
{
LIB$SPAWN("set term/width=132", NULL, NULL);
}
Obviously the 3 CFORTRAN lines above should be put into a header file along
with the description of the other system calls, but as this example shows it's
not much hassle to set up CFORTRAN for even a single call.
-----
Example 3 - CFORTRAN and the source cstring.c create the cstring.obj library
which gives FORTRAN access to all the functions in C's system
library described by the system's C header file string.h.
C EXAMPLE.FOR
PROGRAM EXAMPLE
DIMENSION I(20), J(30)
:
CMEMCPY(I,J,7)
:
END
/* cstring.c */
#include <string.h>
#include "cfortran.h"
#undef fcallsc
#define fcallsc(NAME) C/**/NAME
:
FCALLSCSUB3(memcpy, PVOID, PVOID, INT)
:
N.B. Other than a possible redefinition of fcallsc, cstring.c is machine
independant. Unfortunately the names of C routines called by FORTRAN may
differ from the name of the original C routine, e.g. cmemcpy vs. the original
memcpy. This need never be the case if one has:
i) the original C source code for the routine.
OR ii)a FORTRAN compiler, e.g. f77, which 'renames' routines.
OR iii) a case sensitive linker.
If all the above fail, CFORTRAN, through fcallsc, makes it easy to ensure that
names of C routines called by FORTRAN are modified from the original only when
absolutely neccessary, and if they are modified, that it is done consistently
for any given FORTRAN compiler. [More details below in Section VI.]
-----
II Using CFORTRAN
-----------------
The user is asked to look at the source files CFORTEX.C and CFORTEX.FOR 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: On the RS/6000 a global replace of /**/ by ## makes cfortran.h ANSI
compliant.
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 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.
This is most useful for passing functions as arguments.
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.
Some notes on (P)STRING(V):
STRING - If the argument is a fixed length character array, e.g. char ar[8];,
the string is blank, ' ', padded on the right to fill out the array before
being passed to the FORTRAN routine. The useful size of the string is the same
in both languages, e.g. we pass ar[8] as character*7. If the argument is a
pointer, we cannot blank pad, and pass the length as strlen(argument). On
return from the FORTRAN routine, pointer arguments are not disturbed, arrays
have the terminating '\0' replaced to its original position. i.e. The
padding blanks are never visible to the C code.
PSTRING - The argument is massaged as with STRING before being passed to the
FORTRAN routine. On return, the argument has all trailing blanks removed,
regardless of whether the argument was a pointer or an array.
N.B. Only char arrays are supported for (P)STRINGV. e.g. char bb[6][8];
STRINGV - The elements of the argument are copied into space malloc'd, and each
element is padded with blanks. The useful size of each element is the same in
both languages. Therefore char bb[6][8]; is equivalent to character*7 bb(6).
On return from the routine the malloc'd space is simply released.
PSTRINGV - Since FORTRAN has no trailing '\0', elements in an array of strings
are contiguous. Therefore we pad each element of the C array with blanks and
strip out C's trailing '\0'. After returning from the routine, we reinsert the
trailing '\0' and kill the trailing blanks in each element.
Summary: STRING(V) arguments are blank padded during the call to the FORTRAN
routine, but remain original in the C code. (P)STRINGV arguments are blank
padded for the FORTRAN call, and after returning from FORTRAN trailing blanks
are stripped off.
PVOID, as noted above, is used to declare that a function will be passed as an
argument. In order to perform the call, CFORTRAN must know the language of the
function to be passed, therefore the when passing C functions to FORTRAN
routines use:
FORTRAN_ROUTINE( ...., C_FUNCTION(some_function), ...)
and similarly when passing a FORTRAN routine:
FORTRAN_ROUTINE( ...., FORTRAN_FUNCTION(some_function), ...)
This list of argument types is not neccessarily complete. CFORTRAN may be
expanded to handle a new type not among the above.
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.
VAX VMS user's will have to redefine the one of the macros fcallsc or ccallsc.
See the examples or existing applications for details and information.
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)STRING arguments have any trailing blanks removed before being passed to C,
the same holds true for each element in (P)STRINGV. Space is malloc'd in all
cases big enough to hold the original string (elements) as well as C's
terminatinng '\0'. i.e. The useful size of the string (elements) is the same in
both languages. PSTRING(V) => the string (elements) will be copied from the
malloc'd space back into the FORTRAN bytes.
THE FOLLOWING APPLIES TO THE UNIX COMPILERS ONLY:
----
(P)STRINGV for UNIX only: 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)
Again the lists of types are not neccessarily complete. CFORTRAN may be
expanded to handle a new type not among the above.
===> USER'S OF CFORTRAN NEED READ NO FURTHER <===
III Some Details of and Comments on CFORTRAN
--------------------------------------------
The following notes should be useful to those wishing to port CFORTRAN to new
types of machines.
CFORTRAN.H consist of about 1000 lines of source code. Only about 200 lines of
CFORTRAN.H are interesting, the rest are slightly modified 'repeats'. Porting
CFORTRAN applications, e.g. the hbook.h and cstring.c mentioned above, to
other machines is trivial. hbook.h is machine independant, and cstring.c will
at most need to have the 'fcallsc' macro redefined. Porting CFORTRAN itself
requires a solid knowledge of the new machines C preprocessor, and its FORTRAN
argument passing mechanisms. Logically CFORTRAN exists as two halves, a "C
CALLS FORTRAN" and a "FORTRAN CALLS C" utility. In some cases it may be
perfectly reasonable to port only 'one half' of CFORTRAN onto a new system.
CFORTRAN is simple enough to be used by the most basic of applications, i.e.
making a single C/FORTRAN routine available to the FORTRAN/C programmers. Yet
CFORTRAN is powerful enough to easily make entire C/FORTRAN libraries available
to FORTRAN/C programmers.
CFORTRAN is the ideal tool for FORTRAN libraries which are being rewritten in
C. It allows the routines to be written in 'natural C', without having to
consider the FORTRAN argument passing mechanisms of any machine. It also allows
C code accessing these rewritten routines, to use the C entry point. Without
CFORTRAN one could fall into the perverse practice of C code calling a C
function using FORTRAN argument passing mechanisms!
Perhap the philosophy and mechanisms of CFORTRAN could be used and extended
to create other language bridges such as ADAFORTRAN, CPASCAL, COCCAM, etc.
IV Pros, Cons and Improvements to CFORTRAN
------------------------------------------
The C calls FORTRAN half is all pro. A list would include:
i) Machine independant and C or FORTRAN independant calls to FORTRAN code.
e.g. C : hbook1(1,"pT spectrum of pi+",100,0.,5.,0.);
FORTRAN: call hbook1(1,'pT spectrum of pi+',100,0.,5.,0.)
ii) Non-STRING(V) arguments have no, or at most one assignment as overhead.
iii) 'Input only' arguments are protected by using an intermediate value.
iv) I don't think STRING(V)'s can be handled much faster, even in individually
tuned routines.
The FORTRAN calls C half has the fundamental inelegancy of using an
intermediate function. Perhaps a preprocessor and those %DEF (?) FORTRAN
extensions could help. I don't know, I'm just a C programmer who wants to use
routines written in FORTRAN.
It might make sense to have separate CFORTRAN and FORTRANC utilities, but I've
left them tied together for the moment.
Using FCALLSCFUNn and CCALLSFFUNn for a function in the same source code, i.e.
creating the FORTRAN entry to a C function and then allowing C to call this
FORTRAN entry, obviously serves only test purposes. Note that the order given
above is a must, and that a compiler warning is generated because the FORTRAN
function prototype generated by CCALLSFFUNn does not match the entry point
created by FCALLSCFUNn. This might be fixable, see CFORTRAN.H, but since these
combo.'s are used in tests only, I don't think it's worth it. I say might
because I'm not sure one can satisfy the case sensitive compiler here.
V Machine Dependancies of CFORTRAN
----------------------------------
I leave it to the lucky programmer porting CFORTRAN to a new machine, to
discover the FORTRAN argument passing mechanisms. A safe starting point is to
assume that variables and arrays are simply passed by reference as they are in
VAX VMS and UNIX, but I make no guarantees. Strings, and n-dimensional arrays
of strings are a different story. I doubt that any systems do it quite like VAX
VMS does it, so that the UNIX version may provide an easier starting point.
CFORTRAN uses and abuses the ## operator. Although the ## operator proper does
not exist in VAX VMS nor in MIPS C, a kludge does; /**/ with no space allowed
between the slashes, '/', and the macros or tags one wishes to concatenate.
Note that this kludge can be used in macro definitions, but the VAX VMS
compiler will barf if it is used in source code proper. e.g.
#define concat(a,b) a/**/b /* works*/
{
concat(pri,ntf)("hello"); /* e.g. */
}
N.B. I have learnt of an alternate kludge to /**/ which could replace ##.
On some compilers without ##, /**/ may also not work, this new kludge may be a
way out. For more info., porters of CFORTRAN should contact me.
VI Machine Dependancies of CFORTRAN Applications
------------------------------------------------
The only machine dependancy of CFORTRAN Applications I know of are the names of
routines written in C to be called by FORTRAN. This problem arises under VAX
VMS because the 'interpreter' routine, written in C and called by the FORTRAN
code, needs an object code name for itself different from that of the original
C routine it will try to invoke.
This problem does not exist with some FORTRAN compilers. E.g. MIPS' f77
appends each FORTRAN module name with a single underscore, '_', character.
Hence, if all C interpreter routines are prepended with this '_', all is well.
A similar solution may exist when a case sensitive linker is available.
For other compilers, which leave the FORTRAN name as the module name, there
exist only two situations.
i) If the C source code for the routines is NOT available, the calls to
the C routine from FORTRAN must use a different name. In fortran.h the
'fcallsc' [f-calls-c] macro exists to modify the names of the interpreter
routines in a consistent manner.
ii) If the C source code does exist, a decision for one of the two following
possible resolutions has to be made.
a) The source code is left alone and an identical approach to i) above is
taken. This might be preferable for smaller applications, where the
C expertise doesn't exist or has better things to do.
b) This is the better method in that it maintains absolute transparency
at the user level, unfortunately it is more complicated, but with care
it is just as robust at the user level. In short, the objects compiled
from the original C modules are renamed. This is done in the header
file prototyping the original C routines code. Unfortunately this
translation also has to be done when C code calls the C routine. Since
the name modification is done in the routines header file, it's hidden
from the C user, unless they carefully examines the libraries and/or
object code. In CFORTRAN.H the 'ccallsc' [c-calls-c] macro exists to
modify the names of the original routines in a consistent manner.
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, Mips RISC and IBM RS/6000
are registered trademarks.
/* end: cfortran.doc */
--------------cut for cfortran_unix.h----------------------------------
/* cfortran.h */
/* Burkhard Burow, burow%13313.hepnet@csa3.lbl.gov, U. of Toronto, 1991. */
#if !defined(mips) && !defined(rs6000)
??=error This header file is for the following compilers:
??=error - MIPS C and FORTRAN 2.0. (e.g. Silicon Graphics, DECstations, ...)
??=error - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000
??=error cc -Drs6000 is req.d on the RS/6000.
??=error [Do predefined macros exist for the rs6000 id?]
#else
#ifndef __CFORTRAN_LOADED
#define __CFORTRAN_LOADED 1
#include <string.h>
#include <stdio.h>
#include <stdlib.h>
#ifdef mips
#define C_(A) A/**/_
#define ccallsc(NAME) NAME
#else
#define C_(A) A
#define ccallsc(NAME) CF/**/NAME
#endif
/*-------------------------------------------------------------------------*/
/* UTILITIES USED WITHIN CFORTRAN */
#define MIN(A,B) ((A)<(B)?(A):(B))
#define firstindexlength( A) (sizeof(A) /sizeof(A[0]))
#define secondindexlength(A) (sizeof((A)[0])/sizeof((A)[0][0]))
#define COMMON_BLOCK(C) C_(C)
#define C_FUNCTION(NAME) C_(NAME)
#define FORTRAN_FUNCTION(NAME) C_(NAME)
typedef struct {unsigned short clen, flen;} CFSTRLEN;
/* kill the trailing char t's in string s. */
#define kill_trailing(s,t) kill_trailingn((s),(t),(s)+strlen(s))
/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally
points to the terminating '\0' of s, but may actually point to anywhere in s.
s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
If e<s string s is left unchanged. */
static char *kill_trailingn(char *s, char t, char *e)
{
if (e==s) *e = '\0'; /* Kill the string makes sense here.*/
else if (e>s) { /* Watch out for neg. length string.*/
while (e>s && *--e==t); /* Don't follow t's past beginning. */
e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
}
return s;
}
/* Note the following assumes that any element which has t's to be chopped off,
does indeed fill the entire element. */
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_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
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;
}
#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) CFSTRLEN B;
#define VDOUBLEV( A,B) double *B = A;
#define VFLOATV( A,B) float *B = A;
#define VINTV( A,B) int *B = A;
#define VSTRINGV( A,B) struct {char *s; unsigned flen;} B;
#define VDOUBLEVV(A,B) double *B = A[0];
#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) int B;
#define VPSTRINGV(A,B) struct {unsigned short sizeofA, flen;} B;
#define VPVOID( A,B)
#define VPSTRUCT( 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) CSTRING(A,B,sizeof(A))
#define ADOUBLEV( A,B) B
#define AFLOATV( A,B) B
#define AINTV( A,B) B
#define ASTRINGV( A,B) (B.s=malloc(sizeof(A)-firstindexlength(A)), \
c2fstrv(A[0],B.s,(B.flen=secondindexlength(A)-1)+1,sizeof(A)))
#define ADOUBLEVV(A,B) B
#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) CPSTRING(A,B,sizeof(A))
#define APSTRINGV(A,B) c2fstrv(A[0],A[0],(B.flen=secondindexlength(A)-1)+1, \
B.sizeofA=sizeof(A))
#define APVOID( A,B) (void *) A
#define APSTRUCT( 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) ,B.flen
#define JDOUBLEV( A,B)
#define JFLOATV( A,B)
#define JINTV( A,B)
#define JSTRINGV( A,B) ,B.flen
#define JDOUBLEVV(A,B)
#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) ,B
#define JPSTRINGV(A,B) ,B.flen
#define JPVOID( A,B)
#define JPSTRUCT( A,B)
#define WCF(TN,I) W/**/TN(A/**/I,B/**/I)
#define WDOUBLE( A,B)
#define WFLOAT( A,B)
#define WINT( A,B)
#define WLOGICAL( A,B)
#define WLONG( A,B)
#define WSTRING( A,B) (A[B.clen]!='\0'?A[B.clen]='\0':0);
#define WDOUBLEV( A,B)
#define WFLOATV( A,B)
#define WINTV( A,B)
#define WSTRINGV( A,B) free(B.s);
#define WDOUBLEVV(A,B)
#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((char*)A,(char*)A,B.flen+1,B.sizeofA), B.flen+1,B.sizeofA,' ');
#define WPVOID( A,B)
#define WPSTRUCT( A,B)
#define NDOUBLE double *
#define NFLOAT float *
#define NINT int *
#define NLOGICAL int *
#define NLONG long *
#define NSTRING char *
#define NDOUBLEV double *
#define NFLOATV float *
#define NINTV int *
#define NSTRINGV char *
#define NDOUBLEVV double *
#define NFLOATVV float *
#define NINTVV int *
#define NPDOUBLE double *
#define NPFLOAT float *
#define NPINT int *
#define NPLOGICAL int *
#define NPLONG long *
#define NPSTRING char *
#define NPSTRINGV char *
#define NPVOID void *
#define NPSTRUCT void *
/* WARNING: CCALLSFSUBn and PROTOCCALLSFFUNn use the fact that the arguments to
routines are evaluated left to right. i.e. The J... entries are dependant on
results from the A and the C tables. This works here, but is a hazard when
moving to a different compiler. */
#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 CCALLSFSUB10(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA, \
A1,A2,A3,A4,A5,A6,A7,A8,A9,AA) \
{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) V/**/TA(AA,BA) \
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),A/**/TA(AA,BA) 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) J/**/TA(AA,BA)); \
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) W/**/TA(AA,BA) }
#define CCALLSFSUB11(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB, \
A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB) \
{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) V/**/TA(AA,BA) \
V/**/TB(AB,BB) \
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),A/**/TA(AA,BA),A/**/TB(AB,BB) 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) \
J/**/TA(AA,BA) J/**/TB(AB,BB)); \
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) W/**/TA(AA,BA) \
W/**/TB(AB,BB) }
#define CCALLSFSUB16(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG, \
A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG) \
{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) V/**/TA(AA,BA) \
V/**/TB(AB,BB) V/**/TC(AC,BC) V/**/TD(AD,BD) V/**/TE(AE,BE) V/**/TF(AF,BF) \
V/**/TG(AG,BG) \
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),A/**/TA(AA,BA),A/**/TB(AB,BB),A/**/TC(AC,BC), \
A/**/TD(AD,BD),A/**/TE(AE,BE),A/**/TF(AF,BF),A/**/TG(AG,BG) \
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) J/**/TA(AA,BA) J/**/TB(AB,BB) J/**/TC(AC,BC) \
J/**/TD(AD,BD) J/**/TE(AE,BE) J/**/TF(AF,BF) J/**/TG(AG,BG)); \
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) W/**/TA(AA,BA) \
W/**/TB(AB,BB) W/**/TC(AC,BC) W/**/TD(AD,BD) W/**/TE(AE,BE) W/**/TF(AF,BF) \
W/**/TG(AG,BG) }
#define PROTOCCALLSFSUB0(NAME) void C_(NAME)();
#define PROTOCCALLSFSUB1(NAME,T1) void C_(NAME)(N/**/T1, ...);
#define PROTOCCALLSFSUB2(NAME,T1,T2) void C_(NAME)(N/**/T1,N/**/T2, ...);
#define PROTOCCALLSFSUB3(NAME,T1,T2,T3) void C_(NAME)(N/**/T1,N/**/T2,N/**/T3, \
...);
#define PROTOCCALLSFSUB4(NAME,T1,T2,T3,T4) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4, ...);
#define PROTOCCALLSFSUB5(NAME,T1,T2,T3,T4,T5) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, ...);
#define PROTOCCALLSFSUB6(NAME,T1,T2,T3,T4,T5,T6) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, \
N/**/T6, ...);
#define PROTOCCALLSFSUB7(NAME,T1,T2,T3,T4,T5,T6,T7) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, \
N/**/T6,N/**/T7, ...);
#define PROTOCCALLSFSUB8(NAME,T1,T2,T3,T4,T5,T6,T7,T8) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, \
N/**/T6,N/**/T7,N/**/T8, ...);
#define PROTOCCALLSFSUB9(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, \
N/**/T6,N/**/T7,N/**/T8,N/**/T9, ...);
#define PROTOCCALLSFSUB10(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, \
N/**/T6,N/**/T7,N/**/T8,N/**/T9,N/**/TA, ...);
#define PROTOCCALLSFSUB11(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, \
N/**/T6,N/**/T7,N/**/T8,N/**/T9,N/**/TA, \
N/**/TB, ...);
#define PROTOCCALLSFSUB16(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG)\
void C_(NAME)(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5, \
N/**/T6,N/**/T7,N/**/T8,N/**/T9,N/**/TA, \
N/**/TB,N/**/TC,N/**/TD,N/**/TE,N/**/TF, \
N/**/TG, ...);
/*-------------------------------------------------------------------------*/
/* 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 * /*Needed for FORTRAN calls to C subroutines. */
#define UPSTRUCT 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 BPSTRUCT( A) (void *)&A
#define SDOUBLE( A)
#define SFLOAT( A)
#define SINT( A)
#define SLOGICAL( A)
#define SLONG( A)
#define SSTRING( A) ,sizeof(A)
#define SFLOATV( A)
#define SINTV( A)
#define SSTRINGV( A) ,( (unsigned)0xFFFF*firstindexlength(A) \
+secondindexlength(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) ,sizeof(A)
#define SPSTRINGV SSTRINGV
#define SPVOID( A)
#define SPSTRUCT( A)
#define HDOUBLE( A)
#define HFLOAT( A)
#define HINT( A)
#define HLOGICAL( A)
#define HLONG( A)
#define HSTRING( A) ,unsigned 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) ,unsigned A
#define HPSTRINGV( A) ,unsigned A
#define HPVOID( A)
#define HPSTRUCT( A)
#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) (B.clen=strlen(A), \
C==sizeof(char*)||C==B.clen+1?B.flen=B.clen,(A): \
(memset((A)+B.clen,' ',C-B.clen-1),A[B.flen=C-1]='\0',(A)))
#define CFLOATV( A,B,C) A
#define CINTV( A,B,C) A
#define CSTRINGV( A,B,C) (B.s=malloc((C/0xFFFF)*(C%0xFFFF-1)), \
c2fstrv(A,B.s,(B.flen=C%0xFFFF-1)+1,(C/0xFFFF)*(C%0xFFFF)))
#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) (B=strlen(A), C==sizeof(char*)?(A): \
(memset((A)+B,' ',C-B-1),A[B=C-1]='\0',(A)))
#define CPSTRINGV(A,B,C) c2fstrv(A,A,(B.flen=C%0xFFFF-1)+1, \
B.sizeofA=(C/0xFFFF)*(C%0xFFFF))
#define CPVOID( A,B,C) A
#define CPSTRUCT( A,B,C) 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 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)); WCF(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)); WCF(T1,1) WCF(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)); \
WCF(T1,1) WCF(T2,2) WCF(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)); WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(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)); \
WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(T4,4) WCF(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)); \
WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(T4,4) WCF(T5,5) WCF(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)); \
WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(T4,4) WCF(T5,5) WCF(T6,6) WCF(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 DDOUBLEV( A)
#define DFLOATV( A)
#define DINTV( A)
#define DSTRINGV( A) ,unsigned A
#define DDOUBLEVV( 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 QDOUBLEV( A)
#define QFLOATV( A)
#define QINTV( A)
#define QSTRINGV( A) char *A; unsigned int A/**/N;
#define QDOUBLEVV( A)
#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 QSTRINGV
#define QPVOID( A)
#define LDOUBLE(NAME) A0=ccallsc(NAME)
#define LFLOAT(NAME) A0=ccallsc(NAME)
#define LINT(NAME) A0=ccallsc(NAME)
#define LLOGICAL(NAME) A0=ccallsc(NAME)
#define LLONG(NAME) A0=ccallsc(NAME)
#define LSTRING(NAME) A0=ccallsc(NAME)
#define LVOID(NAME) ccallsc(NAME)
#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 TDOUBLEV( M,A,B,D) A
#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 *)vkill_trailing(f2cstrv(A,B=malloc(B/**/N*(D+1)),D+1,B/**/N*(D+1)),\
D+1,B/**/N*(D+1),' '))
#define TDOUBLEVV(M,A,B,D) A
#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 TSTRING
#define TPSTRINGV TSTRINGV
#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 RDOUBLEV( A,B,D)
#define RFLOATV( A,B,D)
#define RINTV( A,B,D)
#define RSTRINGV( A,B,D) free(B);
#define RDOUBLEVV(A,B,D)
#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))N/**/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))N/**/T1 A1,N/**/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))N/**/T1 A1,N/**/T2 A2,N/**/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))N/**/T1 A1,N/**/T2 A2,N/**/T3 A3,N/**/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))N/**/T1 A1,N/**/T2 A2,N/**/T3 A3,N/**/T4 A4,N/**/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))N/**/T1 A1,N/**/T2 A2,N/**/T3 A3,N/**/T4 A4,N/**/T5 A5, \
N/**/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))N/**/T1 A1,N/**/T2 A2,N/**/T3 A3,N/**/T4 A4,N/**/T5 A5, \
N/**/T6 A6 N/**/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))N/**/T1 A1,N/**/T2 A2,N/**/T3 A3,N/**/T4 A4,N/**/T5 A5, \
N/**/T6 A6 N/**/T7 A7 N/**/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))N/**/T1 A1,N/**/T2 A2,N/**/T3 A3,N/**/T4 A4,N/**/T5 A5, \
N/**/T6 A6 N/**/T7 A7 N/**/T8 A8 N/**/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 && RS/6000 compilers. */
--------------cut for cfortran_vms.h----------------------------------
/* cfortran.h */
/* Burkhard Burow, University of Toronto, July 1991. */
#ifndef __CFORTRAN_LOADED
#define __CFORTRAN_LOADED 1
#ifndef vms
??=error This header file is for VAX VMS C compilers only.
#else
#include <descrip.h>
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
/*-------------------------------------------------------------------------*/
/* UTILITIES USED WITHIN CFORTRAN */
#define MIN(A,B) (A<B?A:B)
#define firstindexlength(A) (sizeof(A)/sizeof(A[0]))
#define secondindexlength(A) (sizeof((A)[0])/sizeof((A)[0][0]))
#define COMMON_BLOCK(C) C
#define C_FUNCTION(NAME) fcallsc(NAME)
#define FORTRAN_FUNCTION(NAME) ccallsc(NAME)
typedef struct dsc$descriptor_s fstring;
#define DSC$DESCRIPTOR_A(DIMCT) \
struct { \
unsigned short dsc$w_length; \
unsigned char dsc$b_dtype; \
unsigned char dsc$b_class; \
char *dsc$a_pointer; \
char dsc$b_scale; \
unsigned char dsc$b_digits; \
struct { \
unsigned : 3; \
unsigned dsc$v_fl_binscale : 1; \
unsigned dsc$v_fl_redim : 1; \
unsigned dsc$v_fl_column : 1; \
unsigned dsc$v_fl_coeff : 1; \
unsigned dsc$v_fl_bounds : 1; \
} dsc$b_aflags; \
unsigned char dsc$b_dimct; \
unsigned long dsc$l_arsize; \
char *dsc$a_a0; \
long dsc$l_m [DIMCT]; \
struct { \
long dsc$l_l; \
long dsc$l_u; \
} dsc$bounds [DIMCT]; \
}
typedef DSC$DESCRIPTOR_A(1) fstringvector;
/*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
#define initfstr(F,C,ELEMNO,ELEMLEN) \
( (F).dsc$l_arsize= ( (F).dsc$w_length =(ELEMLEN) ) \
*( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO) ), \
(F).dsc$a_a0 = ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length ,(F))
/* 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;
}
/* kill the trailing char t's in string s. */
static char *kill_trailing(char *s, char t)
{char *e;
e = s + strlen(s);
if (e>s) { /* Need this to handle NULL string.*/
while (e>s && *--e==t); /* Don't follow t's past beginning. */
e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
}
return s;
}
/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally
points to the terminating '\0' of s, but may actually point to anywhere in s.
s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
If e<s string s is left unchanged. */
static char *kill_trailingn(char *s, char t, char *e)
{
if (e==s) *e = '\0'; /* Kill the string makes sense here.*/
else if (e>s) { /* Watch out for neg. length string.*/
while (e>s && *--e==t); /* Don't follow t's past beginning. */
e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
}
return s;
}
/* Note the following assumes that any element which has t's to be chopped off,
does indeed fill the entire element. */
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_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
return cstr;
}
static char *f2cstrvcopy(char *cstr, fstringvector *f)
{
unsigned i, elem_len;
elem_len = f->dsc$w_length + 1;
/* copy each element and tack the terminating \0 onto each element and kill
trailing blanks. */
for (i=0; i < f->dsc$l_m[0];) {
memcpy(cstr + (elem_len*i), f->dsc$a_pointer + (f->dsc$w_length*i),
f->dsc$w_length);
*(cstr + elem_len*(++i) - 1) = '\0';
kill_trailing(cstr + elem_len*(i-1),' ');
}
return(cstr);
}
static fstringvector *c2fstrvcopy(char *cstr, fstringvector *f,
unsigned elem_len)
{
unsigned i;
/* copy each element but not its last \0 */
for (i=0; i < f->dsc$l_m[0]; i++)
memcpy(f->dsc$a_pointer + (f->dsc$w_length*i),
cstr + (elem_len*i), f->dsc$w_length);
/*convert the remaining \0's into 'blank's */
for (i=0; i < f->dsc$l_arsize; i++)
if (f->dsc$a_pointer[i] == '\0') f->dsc$a_pointer[i] = ' ';
return(f);
}
/*-------------------------------------------------------------------------*/
/* UTILITIES FOR C TO CALL FORTRAN SUBROUTINES */
/* Define lookup tables for how to handle the various types of variables. */
/* Note that the VMS compiler issues warnings if all arguments to a macro
aren't used. Therefore some of the definitions below, as marked, are dummy.
Q: Why the (char *) cast for STRING? */
#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;
/* The sizeof(A) below is just to use A as reqd. by VMS C. */
#define VSTRING( A,B) static struct {fstring f; unsigned clen;} B = \
{{sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
#define VDOUBLEV( A,B) double *B = A;
#define VFLOATV( A,B) float *B = A;
#define VINTV( A,B) int *B = A;
/* The sizeof(A) below is just to use A as reqd. by VMS C. */
#define VSTRINGV( A,B) static fstringvector B = \
{sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,0,1,1,1},1,0,NULL,0,{1,0}};
#define VFLOATVV( A,B) float *B = A[0];
#define VINTVV( A,B) int *B = A[0];
#define VPDOUBLE( A,B) void *B = &A; /* dummy */
#define VPFLOAT( A,B) void *B = &A; /* dummy */
#define VPINT( A,B) void *B = (int *)& A; /* dummy */
#define VPLOGICAL(A,B) void *B = &A; /* dummy */
#define VPLONG( A,B) void *B = &A; /* dummy */
/* The sizeof(A) in VPSTRING(V) is just to use A as reqd. by VMS C. */
#define VPSTRING( A,B) static fstring B = \
{sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
#define VPSTRINGV(A,B) static fstringvector B = \
{sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,0,1,1,1},1,0,NULL,0,{1,0}};
#define VPVOID( A,B) void *B = A;
#define VPSTRUCT( A,B) void *B = (void *)&A; /* dummy */
/* N.B. The first of the following two expressions is a dummy so that the
VMS compiler does not complain that both arguments aren't used. */
#define ADOUBLE( A,B) (A,&B)
#define AFLOAT( A,B) (A,&B)
#define AINT( A,B) (A,&B)
#define ALOGICAL( A,B) (A,&B)
#define ALONG( A,B) (A,&B)
#define ASTRING( A,B) CSTRING(A,B,sizeof(A))
#define ADOUBLEV( A,B) (A,B)
#define AFLOATV( A,B) (A,B)
#define AINTV( A,B) (A,B)
#define ASTRINGV( A,B) (initfstr(B,malloc(sizeof(A)-firstindexlength(A)), \
firstindexlength(A),secondindexlength(A)-1), \
c2fstrv(A[0],B.dsc$a_pointer,secondindexlength(A),sizeof(A)),&B)
#define AFLOATVV( A,B) (A,B)
#define AINTVV( A,B) (A,B)
#define APDOUBLE( A,B) (B,& A)
#define APFLOAT( A,B) (B,& A)
#define APINT( A,B) (B,& A) /* no longer typecast for enum */
#define APLOGICAL(A,B) (B,& A)
#define APLONG( A,B) (B,& A)
#define APSTRING( A,B) CPSTRING(A,B,sizeof(A))
#define APSTRINGV(A,B) (initfstr(B,A[0],firstindexlength(A), \
secondindexlength(A)-1), \
c2fstrv(A[0],A[0],secondindexlength(A),sizeof(A)), &B)
#define APVOID( A,B) (A, B) /* this allows 0 to be passed */
#define APSTRUCT( A,B) (B,&A)
/* N.B. Other than for PSTRING and PSTRINGV the following expressions are dummy
so that the VMS compiler does not complain that the argument isn't used. */
#define WCF(TN,I) W/**/TN(A/**/I,B/**/I)
#define WDOUBLE( A,B) B,A;
#define WFLOAT( A,B) B,A;
#define WINT( A,B) B,A;
#define WLOGICAL( A,B) B,A;
#define WLONG( A,B) B,A;
#define WSTRING( A,B) (A[B.clen]!='\0'?A[B.clen]='\0':0);
#define WDOUBLEV( A,B) B,A;
#define WFLOATV( A,B) B,A;
#define WINTV( A,B) B,A;
#define WSTRINGV( A,B) A,free(B.dsc$a_pointer);
#define WFLOATVV( A,B) B,A;
#define WINTVV( A,B) B,A;
#define WPDOUBLE( A,B) B,A;
#define WPFLOAT( A,B) B,A;
#define WPINT( A,B) B,A;
#define WPLOGICAL(A,B) B,A;
#define WPLONG( A,B) B,A;
#define WPSTRING( A,B) B,kill_trailing(A,' ');
#define WPSTRINGV(A,B) \
vkill_trailing(f2cstrv((char*)A, (char*)A, \
B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0]), \
B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0], ' ');
#define WPVOID( A,B) B,A;
#define WPSTRUCT( A,B) B,A;
#define NDOUBLE double *
#define NFLOAT float *
#define NINT int *
#define NLOGICAL int *
#define NLONG long *
#define NSTRING fstring *
#define NDOUBLEV double *
#define NFLOATV float *
#define NINTV int *
#define NSTRINGV fstringvector *
#define NFLOATVV float *
#define NINTVV int *
#define NPDOUBLE double *
#define NPFLOAT float *
#define NPINT int *
#define NPLOGICAL int *
#define NPLONG long *
#define NPSTRING fstring *
#define NPSTRINGV fstringvector *
#define NPVOID void *
#define NPSTRUCT void *
#define CCALLSFSUB0(NAME) {NAME();}
#define CCALLSFSUB1(NAME,T1,A1) \
{V/**/T1(A1,B1) NAME(A/**/T1(A1,B1)); W/**/T1(A1,B1)}
#define CCALLSFSUB2(NAME,T1,T2,A1,A2) \
{V/**/T1(A1,B1) V/**/T2(A2,B2) NAME(A/**/T1(A1,B1),A/**/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) \
NAME(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/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) \
NAME(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3),A/**/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) \
NAME(A/**/T1(A1,B1),A/**/T2(A2,B2),A/**/T3(A3,B3),A/**/T4(A4,B4), \
A/**/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) \
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)); \
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) \
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)); \
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) \
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)); \
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) \
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)); \
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 CCALLSFSUB10(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7, \
A8,A9,AA) \
{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) V/**/TA(AA,BA) \
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),A/**/TA(AA,BA)); \
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) W/**/TA(AA,BA)}
#define CCALLSFSUB11(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6, \
A7,A8,A9,AA,AB) \
{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) \
V/**/TA(AA,BA) V/**/TB(AB,BB) \
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),A/**/TA(AA,BA),A/**/TB(AB,BB)); 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) W/**/TA(AA,BA) W/**/TB(AB,BB)}
#define CCALLSFSUB16(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG, \
A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG) \
{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) V/**/TA(AA,BA) \
V/**/TB(AB,BB) V/**/TC(AC,BC) V/**/TD(AD,BD) V/**/TE(AE,BE) V/**/TF(AF,BF) \
V/**/TG(AG,BG) \
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),A/**/TA(AA,BA),A/**/TB(AB,BB),A/**/TC(AC,BC), \
A/**/TD(AD,BD),A/**/TE(AE,BE),A/**/TF(AF,BF),A/**/TG(AG,BG)); \
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) W/**/TA(AA,BA) \
W/**/TB(AB,BB) W/**/TC(AC,BC) W/**/TD(AD,BD) W/**/TE(AE,BE) W/**/TF(AF,BF) \
W/**/TG(AG,BG)}
#define PROTOCCALLSFSUB0(NAME) void NAME();
#define PROTOCCALLSFSUB1(NAME,T1) void NAME(N/**/T1);
#define PROTOCCALLSFSUB2(NAME,T1,T2) void NAME(N/**/T1,N/**/T2);
#define PROTOCCALLSFSUB3(NAME,T1,T2,T3) void NAME(N/**/T1,N/**/T2,N/**/T3);
#define PROTOCCALLSFSUB4(NAME,T1,T2,T3,T4) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4);
#define PROTOCCALLSFSUB5(NAME,T1,T2,T3,T4,T5) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5);
#define PROTOCCALLSFSUB6(NAME,T1,T2,T3,T4,T5,T6) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5,N/**/T6);
#define PROTOCCALLSFSUB7(NAME,T1,T2,T3,T4,T5,T6,T7) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5,N/**/T6, \
N/**/T7);
#define PROTOCCALLSFSUB8(NAME,T1,T2,T3,T4,T5,T6,T7,T8) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5,N/**/T6, \
N/**/T7,N/**/T8);
#define PROTOCCALLSFSUB9(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5,N/**/T6, \
N/**/T7,N/**/T8,N/**/T9);
#define PROTOCCALLSFSUB10(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5,N/**/T6, \
N/**/T7,N/**/T8,N/**/T9,N/**/TA);
#define PROTOCCALLSFSUB11(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5,N/**/T6, \
N/**/T7,N/**/T8,N/**/T9,N/**/TA,N/**/TB);
#define PROTOCCALLSFSUB16(NAME,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG)\
void NAME(N/**/T1,N/**/T2,N/**/T3,N/**/T4,N/**/T5,N/**/T6, \
N/**/T7,N/**/T8,N/**/T9,N/**/TA,N/**/TB,N/**/TC, \
N/**/TD,N/**/TE,N/**/TF,N/**/TG);
/*-------------------------------------------------------------------------*/
/* UTILITIES FOR C TO CALL FORTRAN FUNCTIONS */
/* WARNING: (P)STRINGV does not work, when calling 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 UPSTRUCT void *
#define UVOID void * /*Needed for FORTRAN calls to C subroutines. */
#define EDOUBLE double A0;
#define EFLOAT float A0;
#define EINT int A0;
#define ELOGICAL int A0;
#define ELONG long A0;
#define ESTRING static char AA0[MAX_LEN_FORTRAN_FUNCTION_STRING+1]; \
static fstring A0 = \
{MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\
memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
*(AA0+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( B) A0=B(
#define GZFLOAT( B) A0=B(
#define GZINT( B) A0=B(
#define GZLOGICAL( B) A0=B(
#define GZLONG( B) A0=B(
#define GZSTRING( B) B(&A0
#define GDOUBLE( B) A0=B(
#define GFLOAT( B) A0=B(
#define GINT( B) A0=B(
#define GLOGICAL( B) A0=B(
#define GLONG( B) A0=B(
#define GSTRING( B) B(&A0,
#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) (char *) A
#define BFLOATVV( A) (A)[0]
#define BINTVV( A) (A)[0]
#define BPDOUBLE( A) & A
#define BPFLOAT( A) & A
#define BPINT( A) & A /*no longer typecast for enum*/
#define BPLOGICAL( A) & A
#define BPLONG( A) & A
#define BPSTRING( A) (char *) A
#define BPSTRINGV( A) (char *) A
#define BPVOID( A) (void *) A
#define BPSTRUCT( A) (void *) &A
/* In the S.. and H.. tables, all entries other than (P)STRING(V) are dummy. */
#define SDOUBLE( A) ,(A,1)
#define SFLOAT( A) ,(A,1)
#define SINT( A) ,(A,1)
#define SLOGICAL( A) ,(A,1)
#define SLONG( A) ,(A,1)
#define SSTRING( A) ,sizeof(A)
#define SFLOATV( A) ,(A,1)
#define SINTV( A) ,(A,1)
#define SSTRINGV( A) ,( (unsigned)0xFFFF*firstindexlength(A) \
+secondindexlength(A))
#define SFLOATVV( A) ,(A,1)
#define SINTVV( A) ,(A,1)
#define SPDOUBLE( A) ,(A,1)
#define SPFLOAT( A) ,(A,1)
#define SPINT( A) ,(A,1)
#define SPLOGICAL( A) ,(A,1)
#define SPLONG( A) ,(A,1)
#define SPSTRING( A) ,sizeof(A)
#define SPSTRINGV SSTRINGV
#define SPVOID( A) ,(A,1)
#define SPSTRUCT( A) ,(A,1)
#define HDOUBLE( A) ,int A
#define HFLOAT( A) ,int A
#define HINT( A) ,int A
#define HLOGICAL( A) ,int A
#define HLONG( A) ,int A
#define HSTRING( A) ,unsigned A
#define HFLOATV( A) ,int A
#define HINTV( A) ,int A
#define HSTRINGV( A) ,unsigned A
#define HFLOATVV( A) ,int A
#define HINTVV( A) ,int A
#define HPDOUBLE( A) ,int A
#define HPFLOAT( A) ,int A
#define HPINT( A) ,int A
#define HPLOGICAL( A) ,int A
#define HPLONG( A) ,int A
#define HPSTRING( A) ,unsigned A
#define HPSTRINGV( A) ,unsigned A
#define HPVOID( A) ,int A
#define HPSTRUCT( A) ,int A
#define CCF(TN,I) C/**/TN(A/**/I,B/**/I,C/**/I)
#define CDOUBLE( A,B,C) (B,C,&A)
#define CFLOAT( A,B,C) (B,C,&A)
#define CINT( A,B,C) (B,C,&A)
#define CLOGICAL( A,B,C) (B,C,&A)
#define CLONG( A,B,C) (B,C,&A)
#define CSTRING( A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A, \
C==sizeof(char*)||C==B.clen+1?B.f.dsc$w_length=B.clen,&B.f:\
(memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0',&B.f))
#define CFLOATV( A,B,C) (B,C,A)
#define CINTV( A,B,C) (B,C,A)
#define CSTRINGV( A,B,C) ( \
initfstr(B, malloc((C/0xFFFF)*(C%0xFFFF-1)), C/0xFFFF, C%0xFFFF-1), \
c2fstrv(A,B.dsc$a_pointer,C%0xFFFF,(C/0xFFFF)*(C%0xFFFF)) ,&B)
#define CFLOATVV( A,B,C) (B,C,A)
#define CINTVV( A,B,C) (B,C,A)
#define CPDOUBLE( A,B,C) (B,C,A)
#define CPFLOAT( A,B,C) (B,C,A)
#define CPINT( A,B,C) (B,C,A)
#define CPLOGICAL(A,B,C) (B,C,A)
#define CPLONG( A,B,C) (B,C,A)
#define CPSTRING( A,B,C) (B.dsc$w_length=strlen(A),B.dsc$a_pointer=A, \
C==sizeof(char*)?&B:(memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1),\
A[B.dsc$w_length=C-1]='\0',&B))
#define CPSTRINGV(A,B,C) (initfstr(B, A, C/0xFFFF, C%0xFFFF-1), \
c2fstrv(A,A,C%0xFFFF,(C/0xFFFF)*(C%0xFFFF)) ,&B)
#define CPVOID( A,B,C) (B,C,A)
#define CPSTRUCT( A,B,C) (B,C,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(AA0,CFORTRAN_NON_CHAR),' ');
#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.
gcc, on the other hand may be able to avoid the wrapper functions. */
#define PROTOCCALLSFFUN0(F,NAME) \
U/**/F NAME(); /* This is needed to correctly handle the value returned \
N.B. Can only have prototype arg.'s with difficulty, a la G... table since \
FORTRAN functions returning strings have extra arg.'s. Don't bother, since \
this only causes a compiler warning to come up when one uses FCALLSCFUNn and \
CCALLSFFUNn for the same function in the same source code. Something done by \
the experts in tests only.*/ \
static U/**/F CFFUN(NAME)() \
{E/**/F GZ/**/F(NAME)); X/**/F}
#define PROTOCCALLSFFUN1(F,NAME,T1) \
U/**/F NAME(); \
static U/**/F CFFUN(NAME)(U/**/T1 A1 H/**/T1(C1)) \
{VCF(T1,1) E/**/F G/**/F(NAME)CCF(T1,1)); WCF(T1,1) X/**/F}
#define PROTOCCALLSFFUN2(F,NAME,T1,T2) \
U/**/F 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)); \
WCF(T1,1) WCF(T2,2) X/**/F}
#define PROTOCCALLSFFUN3(F,NAME,T1,T2,T3) \
U/**/F 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)); WCF(T1,1)WCF(T2,2)WCF(T3,3)X/**/F}
#define PROTOCCALLSFFUN4(F,NAME,T1,T2,T3,T4) \
U/**/F 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)); \
WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(T4,4) X/**/F}
#define PROTOCCALLSFFUN5(F,NAME,T1,T2,T3,T4,T5) \
U/**/F 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)); \
WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(T4,4) WCF(T5,5) X/**/F}
#define PROTOCCALLSFFUN6(F,NAME,T1,T2,T3,T4,T5,T6) \
U/**/F 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)); \
WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(T4,4) WCF(T5,5) WCF(T6,6) X/**/F}
#define PROTOCCALLSFFUN7(F,NAME,T1,T2,T3,T4,T5,T6,T7) \
U/**/F 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)); \
WCF(T1,1) WCF(T2,2) WCF(T3,3) WCF(T4,4) WCF(T5,5) WCF(T6,6) WCF(T7,7) X/**/F}
/*-------------------------------------------------------------------------*/
/* UTILITIES FOR FORTRAN TO CALL C ROUTINES */
/* Note that the following two macros are dummies. */
/* Applications have to #undef and re- #define at least one of them.
Otherwise the name of the interpretation routine for FORTRAN code will
have the same name as the original C routine.
e.g. If one wishes to prepend a 'c' to C function names when they are
called by FORTRAN:
#undef fcallsc
#define fcallsc(NAME) C##NAME
*/
#define fcallsc(NAME) NAME
#define ccallsc(NAME) NAME
/* Define lookup tables for how to handle the various types of variables. */
/* N.B. Except for (P)STRING(V) the first of the following two expressions is a
dummy so that the VMS compiler does not complain that both arguments aren't
used. */
#define TDOUBLE( A,B) (B,*A)
#define TFLOAT( A,B) (B,*A)
#define TINT( A,B) (B,*A)
#define TLOGICAL( A,B) (B,*A)
#define TLONG( A,B) (B,*A)
#define TSTRING( A,B) ((B=malloc(A->dsc$w_length+1))[A->dsc$w_length]='\0', \
kill_trailing(memcpy(B,A->dsc$a_pointer,A->dsc$w_length),' '))
#define TDOUBLEV( A,B) (B,A)
#define TFLOATV( A,B) (B,A)
#define TINTV( A,B) (B,A)
#define TLOGICALV(A,B) (B,A)
#define TLONGV( A,B) (B,A)
#define TSTRINGV( A,B) \
(B=malloc((A->dsc$w_length+1)*A->dsc$l_m[0]), (void *)f2cstrvcopy(B,A))
#define TPDOUBLE( A,B) (B, (double *)A)
#define TPFLOAT( A,B) (B, (float *)A)
#define TPINT( A,B) (B, (int *)A)
#define TPLOGICAL(A,B) (B, (int *)A)
#define TPLONG( A,B) (B, (long *)A)
#define TPSTRING TSTRING
#define TPSTRINGV TSTRINGV
#define TPVOID( A,B) (B, (void *)A)
#define FDOUBLE double *
#define FFLOAT float *
#define FINT int *
#define FLOGICAL int *
#define FLONG long *
#define FSTRING fstring *
#define FDOUBLEV double *
#define FFLOATV float *
#define FINTV int *
#define FLOGICALV int *
#define FLONGV long *
#define FSTRINGV fstringvector *
#define FPDOUBLE double *
#define FPFLOAT float *
#define FPINT int *
#define FPLOGICAL int *
#define FPLONG long *
#define FPSTRING fstring *
#define FPSTRINGV fstringvector *
#define FPVOID void *
/* N.B. Except for PSTRING(V) the first of the following two expressions is a
dummy so that the VMS compiler does not complain that both arguments aren't
used. */
#define RDOUBLE( A,B) B,A
#define RFLOAT( A,B) B,A
#define RINT( A,B) B,A
#define RLOGICAL( A,B) B,A
#define RLONG( A,B) B,A
#define RSTRING( A,B) A,free(B)
#define RDOUBLEV( A,B) B,A
#define RFLOATV( A,B) B,A
#define RINTV( A,B) B,A
#define RLOGICALV(A,B) B,A
#define RLONGV( A,B) B,A
#define RSTRINGV( A,B) A,free(B)
#define RPDOUBLE( A,B) B,A
#define RPFLOAT( A,B) B,A
#define RPINT( A,B) B,A
#define RPLOGICAL(A,B) B,A
#define RPLONG( A,B) B,A
#define RPSTRING(A,B) memcpy(A->dsc$a_pointer,B,MIN(strlen(B),A->dsc$w_length))\
,(A->dsc$w_length>strlen(B)? \
memset(A->dsc$a_pointer+strlen(B),' ', A->dsc$w_length-strlen(B)):0),free(B)
#define RPSTRINGV(A,B) c2fstrvcopy(B,A,A->dsc$w_length+1), free(B)
#define RPVOID( A,B) B,A
#define MZDOUBLE( A) double fcallsc(A)(
#define MZFLOAT( A) float fcallsc(A)(
#define MZINT( A) int fcallsc(A)(
#define MZLOGICAL( A) int fcallsc(A)(
#define MZLONG( A) long fcallsc(A)(
#define MZSTRING( A) void fcallsc(A)(fstring *AS
#define MZVOID( A) void fcallsc(A)(
#define MDOUBLE( A) double fcallsc(A)(
#define MFLOAT( A) float fcallsc(A)(
#define MINT( A) int fcallsc(A)(
#define MLOGICAL( A) int fcallsc(A)(
#define MLONG( A) long fcallsc(A)(
#define MSTRING( A) void fcallsc(A)(fstring *AS,
#define MVOID( A) void fcallsc(A)(
#define LDOUBLE(NAME) A0=ccallsc(NAME)
#define LFLOAT(NAME) A0=ccallsc(NAME)
#define LINT(NAME) A0=ccallsc(NAME)
#define LLOGICAL(NAME) A0=ccallsc(NAME)
#define LLONG(NAME) A0=ccallsc(NAME)
#define LSTRING(NAME) A0=ccallsc(NAME)
#define LVOID(NAME) ccallsc(NAME)
/* Note that D.. and D.. can't be combined since D.. has to access data before
R.., in order for functions returning strings which are also passed in as
arguments to work correctly. Note that R.. frees and hence may corrupt the
string. */
#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 DDOUBLE
#define DFLOAT
#define DINT
#define DLOGICAL
#define DLONG
#define DSTRING \
memcpy(AS->dsc$a_pointer,A0, MIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))) ); \
AS->dsc$w_length>(A0==NULL?0:strlen(A0))? \
memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ', \
AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0;
/* The above line has to copy the string into the position provided by the
caller. */
#define DVOID
#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) \
MZ/**/T0(NAME)) {U/**/T0 A0; L/**/T0(NAME)(); D/**/T0 I/**/T0}
#define FCALLSCFUN1(T0, NAME, T1) \
M/**/T0(NAME)F/**/T1 A1) {U/**/T0 A0; U/**/T1 B1; \
L/**/T0(NAME)(T/**/T1(A1,B1)); D/**/T0 R/**/T1(A1,B1); I/**/T0}
#define FCALLSCFUN2(T0, NAME, T1, T2) \
M/**/T0(NAME)F/**/T1 A1, F/**/T2 A2) {U/**/T0 A0; U/**/T1 B1; U/**/T2 B2; \
L/**/T0(NAME)(T/**/T1(A1,B1), T/**/T2(A2,B2)); \
D/**/T0 R/**/T1(A1,B1); R/**/T2(A2,B2); I/**/T0}
#define FCALLSCFUN3(T0, NAME, T1, T2, T3) \
M/**/T0(NAME)F/**/T1 A1, F/**/T2 A2, F/**/T3 A3) \
{U/**/T0 A0; U/**/T1 B1; U/**/T2 B2; U/**/T3 B3; \
L/**/T0(NAME)(T/**/T1(A1,B1), T/**/T2(A2,B2), T/**/T3(A3,B3)); \
D/**/T0 R/**/T1(A1,B1); R/**/T2(A2,B2); R/**/T3(A3,B3); I/**/T0}
#define FCALLSCFUN4(T0, NAME, T1, T2, T3, T4) \
M/**/T0(NAME)F/**/T1 A1, F/**/T2 A2, F/**/T3 A3, F/**/T4 A4) \
{U/**/T0 A0; U/**/T1 B1; U/**/T2 B2; U/**/T3 B3; U/**/T4 B4; \
L/**/T0(NAME)(T/**/T1(A1,B1), T/**/T2(A2,B2), T/**/T3(A3,B3), T/**/T4(A4,B4));\
D/**/T0 R/**/T1(A1,B1);R/**/T2(A2,B2); R/**/T3(A3,B3); R/**/T4(A4,B4); I/**/T0}
#define FCALLSCFUN5(T0, NAME, T1, T2, T3, T4, T5) \
M/**/T0(NAME)F/**/T1 A1, F/**/T2 A2, F/**/T3 A3, F/**/T4 A4, F/**/T5 A5) \
{U/**/T0 A0; U/**/T1 B1; U/**/T2 B2; U/**/T3 B3; U/**/T4 B4; U/**/T5 B5; \
L/**/T0(NAME)(T/**/T1(A1,B1), T/**/T2(A2,B2), T/**/T3(A3,B3), T/**/T4(A4,B4), \
T/**/T5(A5,B5)); D/**/T0 R/**/T1(A1,B1); R/**/T2(A2,B2); \
R/**/T3(A3,B3); R/**/T4(A4,B4); R/**/T5(A5,B5); I/**/T0}
#define FCALLSCFUN6(T0, NAME, T1, T2, T3, T4, T5, T6) \
M/**/T0(NAME)F/**/T1 A1,F/**/T2 A2,F/**/T3 A3,F/**/T4 A4,F/**/T5 A5,F/**/T6 A6)\
{U/**/T0 A0; U/**/T1 B1;U/**/T2 B2;U/**/T3 B3;U/**/T4 B4;U/**/T5 B5;U/**/T6 B6;\
L/**/T0(NAME)(T/**/T1(A1,B1), T/**/T2(A2,B2), T/**/T3(A3,B3), T/**/T4(A4,B4), \
T/**/T5(A5,B5), T/**/T6(A6,B6)); D/**/T0 R/**/T1(A1,B1); R/**/T2(A2,B2); \
R/**/T3(A3,B3); R/**/T4(A4,B4); R/**/T5(A5,B5); R/**/T6(A6,B6); I/**/T0}
#define FCALLSCFUN7(T0, NAME, T1, T2, T3, T4, T5, T6, T7) \
M/**/T0(NAME)F/**/T1 A1, F/**/T2 A2, F/**/T3 A3, F/**/T4 A4, \
F/**/T5 A5, F/**/T6 A6, F/**/T7 A7) \
{U/**/T0 A0; U/**/T1 B1; U/**/T2 B2; U/**/T3 B3; U/**/T4 B4; U/**/T5 B5; \
U/**/T6 B6; U/**/T7 B7; \
L/**/T0(NAME)( T/**/T1(A1,B1), T/**/T2(A2,B2), T/**/T3(A3,B3), \
T/**/T4(A4,B4), T/**/T5(A5,B5), T/**/T6(A6,B6), T/**/T7(A7,B7)); \
D/**/T0 R/**/T1(A1,B1); R/**/T2(A2,B2); R/**/T3(A3,B3); R/**/T4(A4,B4); \
R/**/T5(A5,B5); R/**/T6(A6,B6); R/**/T7(A7,B7); I/**/T0}
#endif /* __CFORTRAN_LOADED */
#endif /* This is VMS. */
--------------cut for cfortest.c----------------------------------
/* cfortest.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. */
#if defined(vms) || defined(rs6000)
#undef ccallsc
#define ccallsc(NAME) NAME/**/CF
/* Under VMS and on the rs6000, this differentiates the original C routine name
from that of the FORTRAN entry point, i.e. that of the cfortran generated
wrapper. It isn't needed under MIPS Risc because the f77 appends the
underscore character, '_', to all external references. See cfortran.doc for
more details.*/
#endif
#ifdef N1_SELECT
PROTOCCALLSFFUN1(INT,n1,PSTRINGV)
#define N1(A1) CCALLSFFUN1(n1,PSTRINGV,A1)
main() {
static char b[][16] = {"01234","56789"};
N1(b); /*printf("n1(b) returns %d; ", N1(b)); */
printf("with b[0] = %s;\n", b[0]);
printf("and b[1] = %s;\n", b[1]);
}
#endif
#ifndef jkhjhk
#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)
int 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 => malloc'd copy for FORTRAN=> C intact.\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 => malloc'd copy for FORTRAN=> C intact.\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. */
#define EXIST ccallsc(exist)
void EXIST() {printf("EXIST: was called.\n");}
FCALLSCSUB0(exist)
#define CA ccallsc(ca)
void CA(int i) {printf("CA: had integer argument:%d.\n",i);}
FCALLSCSUB1(ca,INT)
#define CB ccallsc(cb)
void CB(int *i) {
printf("CB: had pointer argument to integer:%d.\n",*i); *i*=2;}
FCALLSCSUB1(cb,PINT)
#define CC ccallsc(cc)
void CC(char *s) {printf("CC: had string argument:%s.\n",s);}
FCALLSCSUB1(cc,STRING)
#define CD ccallsc(cd)
void CD(char *s)
{printf("CD: had string argument:%s.\n",s); strcpy(s,"to you 12345678");}
FCALLSCSUB1(cd,PSTRING)
#define CE ccallsc(ce)
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)
#define CF ccallsc(cf)
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)
#define CG ccallsc(cg)
int CG() {return 1;}
FCALLSCFUN0(INT,cg)
#define CH ccallsc(ch)
char *CH() {return "hello";}
FCALLSCFUN0(STRING,ch)
#define CI ccallsc(ci)
char *CI(char v[][5]) {return v[3];}
#define ci_STRV_A1 NUM_ELEMS(6)
FCALLSCFUN1(STRING,ci,STRINGV)
#define CJ ccallsc(cj)
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", ""};
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
#endif
--------------cut for cfortex.for----------------------------------
C cfortex.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(4)
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(4)
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*,'FF:len(v(1 or 2 or 3 or 4)) =',len(v(1))
print*,'FF:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
print*,'FF: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 of posting---apologies for the lenght---------------------