/* f2cvv.c

        Copyright (c) Kapteyn Laboratorium Groningen 1990,
        Kapteyn Astronomical Institute 2011,
        All Rights Reserved.

#>            f2cvv.doc

Program:      f2cvv

Purpose:      This program generates C code for the F2C/C2F interface
              routines.

Category:     SYSTEM

File:         f2cvv.c

Author:       K.G. Begeman

Description:  This program creates c source code for the intermediate
              routines necessary to call C routines from Fortran and
              Fortran routines from C. The name of the Fortran
              callable routine is as stated in the document, the C
              callable routine has the same name with postfix '_c'.
              All arguments are passed by reference, except fortran
              character arguments. For Fortran character types a
              special C type has been defined, fchar, which is a
              struct which holds the address of the Fortran character
              string and its length. For the Fortran types integer,
              integer(kind=8), logical and complex C types fint, fint8,
              bool and complex are defined. The correspondence of fortran
              types with C types is as follows:
                      FORTRAN                   C
                      integer        <->     * fint
                      integer*8      <->     * fint8
                      logical        <->     * bool
                        real         <->     * float
                   double precision  <->     * double
                      complex        <->     * complex
                     character       <->       fchar
              Except for fortran character functions, the number and
              type of arguments correspond as stated above. Fortran
              character functions correspond with C procedures of type
              void with an extra fchar as first argument, which corresponds
              with the character returned by the fortran function.
              A fchar struct contains a character pointer 'a' to the
              Fortran character string and a fint 'l' which holds the
              length of the character string.
              A complex struct contains a float 'r' which holds the
              real part and a float 'i' which holds the imaginary part.
              For the interpretation of fortran logicals, two macros are
              defined, tobool(l) and toflog(l); tobool converts a Fortran
              logical to a C true or false value, toflog converts a C true
              or false value to a Fortran logical. To set a bool to a
              Fortran .TRUE. or .FALSE., the macros TRUE and
              FALSE can be used. These four macros are defined in the
              definition file generated by f2cvv.

Operation:    The program reads the routine definition from the source
              file. The routine definition is placed in the comment area
              of the source code and should be preceded by '@' in the
              first or second column on each new line. The syntax of the
              routine definition is as follows:

              procedure_name ( [type [, type [, type [ ... ] ] ] ] )

              where:

              procedure_name = { subroutine }, { type function }

              type = { character }, { integer }, {integer*8}, { logical },
                     { real }, { double precision }, { complex }

              Note that integer(kind=8) is specified here as integer*8.

Use:          F2CVV <source>.<extension>
              From the extension of the input source F2CVV deduces
              whether an F2C or an C2F interface should be created.
              Recognized extensions are:
                 c                 C source
                 f                 FORTRAN source
                 for               FORTRAN source
                 shl               SHELTRAN source
              The resulting interface is in <source>_ftoc.c or
              in <source>_ctof.c depending whether the input source
              is in C or Fortran/Sheltran.
              For each <entry> in the <source> an <entry>.h file is
              created by F2CVV which holds the template of the procedure
              which can be used by C programmers.
              When a file with extension h is entered on the command line,
              F2CVV will generate an include file with that name which
              holds the definitions (typedefs) for the different c types
              and defines the macros described above.
              C programmers have to include this file into their source
              in order to define the different C types.

Example:      FORTRAN source sub.f:
                    subroutine sub( a, b, c )
                    character*(*) a
                    integer       b
                    real          c
              C     Next follows the definition for F2Cvv:
              C@    subroutine sub( character, integer, real )
                    .....
                    end
                    character*(*) function fie( a, b )
                    logical a
                    integer b
              C     Next follows the definition for F2Cvv:
              C@    character function fie( logical, integer )
                    .....
                    end
              F2CVV creates: sub.h, fie.h and sub_ctof.c
              sub.h: extern void sub_c( fchar, fint *, float *);
              fie.h: extern void fie_c( fchar, bool *, fint *);

Notes:        F2CVV works only for ANSI C compilers. Interfaces are
              implemented for ALLIANT, ALPHA OSF1, CONVEX, HP, IBM AIX,
              DECSTATIONS, SILICON GRAPHICS, SONY, SUN and VMS. Also an
              interface to the public domain Fortran to C compiler is
              implemented. You should compile this programme with -D__F2C__.
              For use with the gnu fortran 77 compiler compile with -D__g77__.
              For ALLIANT, ALPHA OSF1, IBM AIX, DECSTATIONS and SILICON
              GRAPHICS there are some auxiliary routines necessary which
              can be found in f2cvv_aux.src. The source code of these routines
              is extracted with xfile.

              The name of the fortran routines as seen by a c program
              is usually the default name convention of the fortran
              compiler. Some fortran compilers allow you to add an underscore
              to this name. If you want to compile your fortran sources
              with this compiler option, compile f2cvv with
              -DALWAYS_UNDERSCORE on the command line.
              There are also some test programs in the f2cvv source file.
              They test the F2C and C2F interface. To test the interface
              program do the following: xfile -DTESTBED f2cvv.c
              This command will extract subc.c subf.f mainc.c mainf.f and
              Makefile.

              Currently this program is only maintained for Linux and
              Mac OS X, for g77 (deprecated) and gfortran.

Updates:      May 16, 1989 : KGB, Creation date.
              Apr  9, 1990 : KGB, Adapted for GNU (gcc) compiler.
              May 23, 1990 : KGB, Implemented for HP.
              Feb  5, 1993 : KGB, Implemented for gcc on HP and f2c.
              Sep  1, 1996 : KGB, Implemented for g77.
              May  4, 2007 : JPT, Implemented for Apple Mac.
              Mar 11, 2011 : JPT, Support for 64 bit integers.
#<

*/

#include	"osdef.h"			/* define __'machine'__ */
#include	<ctype.h>
#include	<stdio.h>
#include	<stdlib.h>
#include	<string.h>
#include	<stdint.h>

#if	defined(__g77__) | defined(__linux__) | defined(__FreeBSD__) | defined (__APPLE__)
#ifndef	__F2C__
#define	__F2C__
#endif
#endif

#if	defined(__F2C__)			/* standard interface */
#ifdef	__aix__
#undef	__aix__
#endif
#ifdef	__alliant__
#undef	__alliant__
#endif
#ifdef  __alpha__
#undef  __alpha__
#endif
#ifdef	__convex__
#undef	__convex__
#endif
#ifdef	__FreeBSD__
#undef	__FreeBSD__
#endif
#ifdef	__freebsd__
#undef	__freebsd__
#endif
#ifdef	__hpux__
#undef	__hpux__
#endif
#ifdef	__hp9000s300__
#undef	__hp9000s300__
#endif
#ifdef	__hp9000s700__
#undef	__hp9000s700__
#endif
#ifdef	__hp9000s800__
#undef	__hp9000s800__
#endif
#ifdef	__linux__
#undef	__linux__
#endif
#ifdef	__mips__
#undef	__mips__
#endif
#ifdef	__sgi__
#undef	__sgi__
#endif
#ifdef	__sony__
#undef	__sony__
#endif
#ifdef	__sun__
#undef	__sun__
#endif
#ifdef	__vms__
#undef	__vms__
#endif
#endif
static char *types[] = {			/* The symbols we know of */
   "subroutine",				/* 0 */
   "function",					/* 1 */
   "integer",					/* 2 */
   "logical",					/* 3 */
   "character",					/* 4 */
   "real",					/* 5 */
   "complex",					/* 6 */
   "double",					/* 7 */
   "precision",					/* 8 */
   "integer*8"	  				/* 9, later 13 */
};

#define	EOL		'\n'			/* end of line character */
#define	FLAG		'@'			/* flag character in first or secondcolumn */
#define	MAXARGS		128			/* maximum number of arguments in call */
#define	MAXLINE		255			/* maximum length of line */
#define	MAXTYPES	(sizeof(types)/sizeof(char *))	/* known types */

static	FILE	*in;		/* Input source file with F2CVV instructions */
static	FILE	*ou;		/* Output file containing the code generated by F2CVV */
static	FILE	*df;		/* Procedure definition file generated by F2CVV */
static	int	ftoc;		/* FORTRAN to C or C to FORTRAN */
static	int	nargs;		/* number of arguments in procedure call */
static	int	args[MAXARGS];	/* array to store argument types in one call */
static	int	ftype;		/* type of procedure */
static	int	header;		/* did we already write a heading */
static	int	pos;		/* position in line buffer */
static	int	linein;		/* number of characters in line buffer */
static	char	ch;		/* character read from file */
static	char	line[MAXLINE];	/* buffer to hold one line read from input file */
static	char	hnam[80];	/* <entry>.h */
static	char	symb[80];	/* symbol name */
static	char	pnam[80];	/* name of procedure */
static	char	fnam[80];	/* fortran name of procedure in C source */
static	char	cnam[80];	/* c name of procedure */
static	char	onam[80];	/* name of operating system */
static	char	inname[80];	/* name of input file */
static	char	ouname[80];	/* name of output file */


static	int	implemented( void )
/*
 * This function checks whether F2CVV can run on this operating system.
 * For implementations on other machines F2CVV will compile but not
 * run if the machine is not known to this procedure.
 * The appropriate symbol has to be set in osdef.h. The symbol should
 * be something like __'architecture'__.
 * Machines on which F2CVV should run:
 * Machine    OS          Compiler       Remarks
 * VAX        VMS         CC             Not real ANSI, but okay
 * CONVEX     CONVEX UNIX CC             ANSI
 * ALLIANT    Concentrix  GCC            ANSI
 * SUN        SUNOS       GCC            ANSI
 * SONY       NEWS-OS     GCC            ANSI
 * DECstation ULTRIX      GCC            ANSI
 * HP 9000    HP-UX       CC             ANSI with -Aa switch (sometimes)
 * IBM RS6000 AIX         XLC            ANSI
 * Note: f2cvv will always run when compiled with -D__F2C__. Then it will
 * create an interface with the public domain fortran to c (f2c) compiler.
 */
{
   int	okay = 0;				/* return value */

#if	defined(__F2C__)			/* standard (?) interface */
   okay = 1;
   strcpy( onam, "F2C" );
#elif	defined(__aix__)			/* It runs on IBM AIX */
   okay = 1;
   strcpy( onam, "AIX" );
#elif	defined(__alliant__)			/* It runs on ALLIANT systems */
   okay = 1;
   strcpy( onam, "ALLIANT" );
#elif   defined(__alpha__)
   okay = 1;
   strcpy( onam, "ALPHA" );
#elif	defined(__convex__)			/* It runs on CONVEX systems */
   okay = 1;
   strcpy( onam, "CONVEX" );
#elif	defined(__hpux__)			/* It runs on HP systems */
#if	defined(__hp9000s300__) | defined(__hp9000s700__) | defined(__hp9000s800__)
   okay = 1;
   strcpy( onam, "HPUX" );
#endif
#elif	defined(__mips__)			/* It runs on MIPS systems */
   okay = 1;
   strcpy( onam, "MIPS" );
#elif	defined(__sgi__)			/* It runs on silicon graphics systems */
   okay = 1;
   strcpy( onam, "SGI" );
#elif	defined(__sony__)			/* It runs on SONY systems */
   okay = 1;
   strcpy( onam, "SONY" );
#elif	defined(__sun__)			/* It runs on SUN systems */
   okay = 1;
   strcpy( onam, "SUN" );
#elif	defined(__vms__)			/* It runs on VAX/VMS operating systems */
   okay = 1;
   strcpy( onam, "VMS" );
#endif
   return( okay );				/* return to caller */
}


static	void	f2cvvdefs( FILE *f, int defs )
/*
 * This routine generates the typedefs for the interface routines.
 * This part is system dependent!
 * At the moment all systems for which F2CVV is implemented have the
 * same type of C integer corresponding with the fortran integer.
 */
{
#if	defined(__F2C__)
   int	f2c_def = 1;
#else
   int	f2c_def = 0;
#endif
#if	defined(__aix__)
   int	aix_def = 1;
#else
   int	aix_def = 0;
#endif
#if	defined(__alliant__)
   int	alliant_def = 1;
#else
   int	alliant_def = 0;
#endif
#if     defined(__alpha__)
   int  alpha_def = 1;
#else
   int  alpha_def = 0;
#endif
#if	defined(__convex__)
   int	convex_def = 1;
#else
   int	convex_def = 0;
#endif
#if defined(__hpux__)
   int	hp_def = 1;
#else
   int	hp_def = 0;
#endif
#if	defined(__mips__)
   int	mips_def = 1;
#else
   int	mips_def = 0;
#endif
#if	defined(__sgi__)
   int	sgi_def = 1;
#else
   int	sgi_def = 0;
#endif
#if	defined(__sony__)
   int	sony_def = 1;
#else
   int	sony_def = 0;
#endif
#if	defined(__sun__)
   int	sun_def = 1;
#else
   int	sun_def = 0;
#endif
#if	defined(__vms__)
   int vms_def = 1;
#else
   int vms_def = 0;
#endif
   if (defs) {
      fprintf( f, "/%c %s", '*', hnam );
      fprintf( f, "\n" );
      fprintf( f, "\n\tCopyright (c) Kapteyn Astronomical Institute Groningen 1993, 2011" );
      fprintf( f, "\n\tAll Rights Reserved." );
      fprintf( f, "\n" );
      fprintf( f, "\n#>            %.*s.dc3", (int)(strlen( hnam ) - strlen( strchr( hnam, '.' ) )), hnam );
      fprintf( f, "\n" );
      fprintf( f, "\nHeader:       %s", hnam );
      fprintf( f, "\n" );
      fprintf( f, "\nPurpose:      Contains the f2cvv definitions generated by program f2cvv." );
      fprintf( f, "\n" );
      fprintf( f, "\nFile:         %s", hnam );
      fprintf( f, "\n" );
      fprintf( f, "\nAuthor:       K.G. Begeman" );
      fprintf( f, "\n" );
      fprintf( f, "\nUse:          #include \"%s\"", hnam );
      fprintf( f, "\n" );
      fprintf( f, "\nDefines:      fchar (fortran character), a struct with a pointer to" );
      fprintf( f, "\n              a character string (a) and a length (l)." );
      fprintf( f, "\n              complex (fortran complex), a struct with a real (r) and" );
      fprintf( f, "\n              an imaginary part (i)." );
      fprintf( f, "\n              fint (fortran integer)." );
      fprintf( f, "\n              fint8 (64-bit fortran integer)." );
      fprintf( f, "\n              bool (fortran logical)." );
      fprintf( f, "\n              tobool and toflog, macros to convert from fortran logical" );
      fprintf( f, "\n              to c logical and vv." );
      fprintf( f, "\n              TRUE and FALSE, fortran .TRUE. and .FALSE." );
      fprintf( f, "\n" );
      fprintf( f, "\nUpdates:      Jul  7, 1993: KGB, Document created." );
      fprintf( f, "\n              Mar 11, 2011: JPT, 64-bit integer support." );
      fprintf( f, "\n" );
      fprintf( f, "\n#<" );
      fprintf( f, "\n" );
      fprintf( f, "\n%c/", '*' );
      fprintf( f, "\n" );
      fprintf( f, "\n/%c f2cvv definitions generated by program f2cvv %c/", '*', '*' );
      fprintf( f, "\n#ifndef _F2CVVDEFS_H_" );
      fprintf( f, "\n#define _F2CVVDEFS_H_" );
      fprintf( f, "\n" );
      fprintf( f, "\n#ifdef  TRUE" );
      fprintf( f, "\n#undef  TRUE" );
      fprintf( f, "\n#endif" );
      fprintf( f, "\n#ifdef  FALSE" );
      fprintf( f, "\n#undef  FALSE" );
      fprintf( f, "\n#endif" );
   }
   fprintf( f, "\n" );
   if (defs || f2c_def) {
      fprintf( f, "\n#include <stdint.h>" );
      fprintf( f, "\n#if     defined(__g77__) | defined(__F2C__) | defined(__linux__) | defined(__FreeBSD__) | defined(__APPLE__)" );
      fprintf( f, "\n#if     defined(__APPLE__) && !defined(__x86_64__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\n#else" );
      fprintf( f, "\ntypedef int fint;" );
      fprintf( f, "\ntypedef int bool;" );
      fprintf( f, "\n#endif" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\ntypedef int64_t fint8;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#else" );
   }
   if (defs || aix_def) {
      fprintf( f, "\n#if     defined(_AIX) | defined(__aix__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l & 0x00000001 ? 1 : 0 )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || alliant_def) {
      fprintf( f, "\n#if     defined(alliant) | defined(__alliant__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l & 0x00000001 ? 1 : 0 )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || alpha_def) {
      fprintf( f, "\n#if     defined(__alpha) | defined(__alpha__)" );
      fprintf( f, "\ntypedef int fint;" );
      fprintf( f, "\ntypedef int bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || convex_def) {
      fprintf( f, "\n#if     defined(convex) | defined(__convex__) | defined(__convexc__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || hp_def) {
      fprintf( f, "\n#if     defined(__hpux) | defined(__hpux__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#if     defined(__hp9000s300) | defined(__hp9000s300__)" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#elif   defined(__hp9000s700) | defined(__hp9000s700__) | defined(__hppa__)" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#elif   defined(__hp9000s800) | defined(__hp9000s800__)" );
      fprintf( f, "\n#define TRUE            ( 0x01000000 )" );
      fprintf( f, "\n#define FALSE           ( 0x00000000 )" );
      fprintf( f, "\n#define tobool(l)       ( l & 0x01000000 ? 0x01000000 : 0 )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 0x01000000 : 0x00000000 )" );
      fprintf( f, "\n#endif" );
      fprintf( f, "\n#endif" );
   }
   if (defs || mips_def) {
      fprintf( f, "\n#if     defined(mips) | defined(__mips__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || sgi_def) {
      fprintf( f, "\n#if     defined(__sgi) | defined(__sgi__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || sony_def) {
      fprintf( f, "\n#if     defined(sony) | defined(__sony__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || sun_def) {
      fprintf( f, "\n#if     defined(sun) | defined(__sun__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || vms_def) {
      fprintf( f, "\n#if     defined(vms) | defined(__vms__)" );
      fprintf( f, "\ntypedef long fint;" );
      fprintf( f, "\ntypedef long bool;" );
      fprintf( f, "\ntypedef struct { char *a; fint  l; } fchar;" );
      fprintf( f, "\ntypedef struct { float r; float i; } complex;" );
      fprintf( f, "\n#define TRUE            ( 1 )" );
      fprintf( f, "\n#define FALSE           ( 0 )" );
      fprintf( f, "\n#define tobool(l)       ( l )" );
      fprintf( f, "\n#define toflog(l)       ( l ? 1 : 0 )" );
      fprintf( f, "\n#endif" );
   }
   if (defs || f2c_def) {
      fprintf( f, "\n#endif" );
   }
   if (defs) {
      fprintf( f, "\n" );
      fprintf( f, "\n#endif" );
      fprintf( f, "\n" );
   }
}


static	void	hname( void )
/*
 * This function generates the name of the procedure definition file.
 * This is NOT system dependent!
 */
{
   strcpy( hnam, pnam );
   strcat( hnam, ".h" );
}


static	void	cname( void )
/*
 * This procedure generates the C name of the procedure.
 * This is NOT system dependent!
 */
{
   strcpy( cnam, pnam );
   strcat( cnam, "_c" );
}


static	void	fname( void )
/*
 * This procedure generates the name of the FORTRAN procedure.
 * This is system dependent! Here is a list of FORTRAN routine names and
 * corresponding C names for the implemented operating systems.
 * Machine/OS              FORTRAN name       C name
 * VAX/VMS                 sub                sub
 * ALLIANT/Concentrix      sub                sub_
 * SUN/SUNOS               sub                sub_
 * CONVEX                  sub                sub_
 * SONY                    sub                sub_
 * MIPS                    sub                sub_
 * HP-UX                   sub                sub
 * IBM AIX                 sub                sub
 * SILICON GRAPHICS        sub                sub_
 * ALPHA                   sub                sub_
 * The public domain f2c compiler generates names with at least one
 * underscore appended, and two if the name itself contains an underscore.
 */
{
   strcpy( fnam, pnam );
#if	defined(__F2C__)
   {
      char	*p = fnam;
      char	ch;
      int	count = 0;

      while ((ch = *p++)) { if (ch == '_') count++; }
      if (count) {
         strcat( fnam, "__" );
      } else {
         strcat( fnam, "_" );
      }
   }
#elif	defined(ALWAYS_UNDERSCORE) | defined(__alliant__) | defined(__alpha__) | defined(__convex__) | defined(__mips__) | defined(__sgi__) | defined(__sony__) | defined(__sun__)
   strcat( fnam, "_" );
#endif
}


static	int	findflag( void )
/*
 * This function determines whether the F2CVV flag character is present
 * in the current line.
 * It returns the position of the next character which is of interest to
 * F2CVV in the line buffer, or, if not a flagged line, zero.
 */
{
   int	p = 0;

   if (linein < 2) return(0);
   if (line[p++] == FLAG) return(1);
   if (line[p++] == FLAG) return(2);
   return(0);
}


static	int	nextline( void )
/*
 * This function reads the next line from the input file and returns
 * the number of characters read.
 * The characters are all checked whether they are printable.
 * If END_OF_FILE is encountered, EOF will be returned.
 */
{
   int	ch;

   linein = 0;
   if (feof(in)) return(EOF);
   ch = fgetc(in);
   while ((ch != EOL) && (ch != EOF)) {
      if (linein < (MAXLINE - 1)) {
         if (isspace(ch)) {
            line[linein++] = ' ';
         } else if (isprint(ch)) {
            line[linein++] = ch;
         }
      }
      ch = fgetc(in);
   }
   line[linein] = 0;
   return(linein);
}


static	int	nextch( void )
/*
 * This procedure finds the next character which is part of the
 * instruction for F2CVV.
 * It is not checked whether the instructions for F2CVV are in the
 * comment area.
 */
{
   int	chr = 0;

   do {
      if (pos) chr = tolower(line[pos++]);
      if (!chr) pos = 0;
      if (!pos) {
         if (nextline() == EOF) break;			/* end_of_file, leave loop */
         pos = findflag();
      }
   } while (!chr);
   return(chr);
}


static	int	nextsym( void )
/*
 * This function finds the next symbol. This routine is not system
 * dependent.
 * The following numbers are returned:
 * return value          symbol
 * -1                    unknown symbol
 *  0                    subroutine
 *  1                    function
 *  2                    integer
 *  3                    logical
 *  4                    character
 *  5                    real
 *  6                    complex
 *  7                    double
 *  8                    precision
 *  9                    right parenthesis ')'
 * 10                    left parenthesis '('
 * 11                    comma ','
 * 12                    END_OF_FILE
 */
{
   int	ret = -1;

   while (ch == ' ') ch = nextch();
   switch(ch) {
      case '(': ch = nextch(); ret = 9; break;
      case ')': ch = nextch(); ret = 10; break;
      case ',': ch = nextch(); ret = 11; break;
      case 0  : ret = 12; break;
      default : {
         int	m = 0, n = 0;

         while ((ch != 0) && (ch != ' ') && (ch != '(') && (ch != ')') && (ch != ',')) {
            symb[n++] = ch;
            ch = nextch();
         }
         symb[n] = 0;
         while ((m < MAXTYPES) && strcmp(types[m],symb)) m++;
         if (m < MAXTYPES) ret = m;
         if (ret==9) ret = 13;
      }
   }
   return(ret);
}


static	int	decode( void )
/*
 * This function decodes the F2CVV instructions.
 * The returned value has the following meaning:
 * return value        meaning
 * -1                  normal end, no output created
 *  0                  successfull decoding
 *  1                  syntax error
 *  2                  missing function type
 *  3                  'precision' after 'double' missing
 *  4                  'function' missing
 *  5                  procedure name missing
 *  6                  ( missing
 *  7                  unknown type of argument
 *  8                  argument buffer overflow
 *  9                  illegal procedure name
 */
{
   int	t;

   t = nextsym();
   if (t == 12) return(-1);			/* we're done */
   if ((t < 0) && (t > 7)) return(1);		/* syntax error */
   if (t == 1) return(2);			/* missing function type */
   ftype = t;
   if (ftype) {
      if (t == 7) {
         if (nextsym() != 8) return(3);		/* precision missing */
      }
      if (nextsym() != 1) return(4);		/* function missing */
   }
   if (nextsym() != -1) return(5);		/* procedure name missing */
   if (!isalpha(symb[0])) return(9);		/* illegal procedure name */
   strcpy( pnam, symb );
   if (nextsym() != 9) return(6);		/* ( missing */
   nargs = 0;					/* decode arguments */
   t = nextsym();
   while (t != 10) {
      if (t == 7) if (nextsym() != 8) return(3);/* precision missing */
      if (((t > 1) && (t < 8)) || (t==13)) {
         if (nargs < MAXARGS) args[nargs++] = t; else return(8);
         t = nextsym();
      } else {
         return(7);				/* unknown type */
      }
      if (t == 11) t = nextsym();
   }
   return(0);					/* normal end */
}


static	void	encode_ftoc( void )
/*
 * This procedure generates the source code for the F to C interface.
 * This routine is system dependent.
 */
{
   int	n;
   int	comma;
   int	ns;
   char	spaces[80];

/*
 * STEP 1.
 *
 * Generate the heading of the source.
 */
   if (!header) {				/* print header of output file */
      if ((ou = fopen( ouname, "w")) == NULL) {
         fprintf( stderr, "[f2cvv] Error opening %s\n", ouname );
         exit(EXIT_FAILURE);
      }
      fprintf( ou, "/%c ANSI F2C interface generated for %s by program f2cvv %c/", '*', onam, '*' );
/*
 * STEP 1a.
 *
 * Some machines need some extra definitions like SUN and VMS.
 */
#if	defined(__sun__)
      fprintf( ou, "\n" );
      fprintf( ou, "\n#if defined(mc68000) | defined(__mc68000__)" );
      fprintf( ou, "\n#define FLOATFUNCTIONTYPE       int" );
      fprintf( ou, "\n#define RETURNFLOAT(x)          return (*(int *)(&(x)))" );
      fprintf( ou, "\n#define ASSIGNFLOAT(x,y)        *(int *)(&x) = y" );
      fprintf( ou, "\n#endif" );
      fprintf( ou, "\n#if defined(sparc) | defined(__sparc__)" );
      fprintf( ou, "\n#define FLOATFUNCTIONTYPE       double" );
      fprintf( ou, "\n#define RETURNFLOAT(x)          { union {double _d ; float _f ; } _kluge ; _kluge._f = (x) ; return _kluge._d ; }" );
      fprintf( ou, "\n#define ASSIGNFLOAT(x,y)        { union {double _d ; float _f ; } _kluge ; _kluge._d = (y) ; x = _kluge._f ; }" );
      fprintf( ou, "\n#endif" );
      fprintf( ou, "\n#if defined(i386) | defined(__i386__)" );
      fprintf( ou, "\n#define FLOATFUNCTIONTYPE       float" );
      fprintf( ou, "\n#define RETURNFLOAT(x)          return (x)" );
      fprintf( ou, "\n#define ASSIGNFLOAT(x,y)        x = y" );
      fprintf( ou, "\n#endif" );
#elif	defined(__vms__)
      fprintf( ou, "\n" );
      fprintf( ou, "\n#include <descrip.h>");
#endif
/*
 * STEP 1b.
 *
 * Define the types.
 */
      f2cvvdefs( ou, 0 );
/*
 * STEP 1c.
 *
 * Some machines need some auxiliary routines, like AIX, ALLIANT, ALPHA
 * and MIPS, or definitions, like HP9000S700.
 */
#if	defined(__aix__)
      fprintf( ou, "\n" );
      fprintf( ou, "\nextern void return_complex_aix(complex);" );
#elif	defined(__alliant__)
      fprintf( ou, "\n" );
      fprintf( ou, "\nextern char *a_alliant(fint);" );
      fprintf( ou, "\nextern fint l_alliant(fint);" );
      fprintf( ou, "\nextern void return_complex_alliant(complex);" );
#elif	defined(__alpha__)
      fprintf( ou, "\n" );
      fprintf( ou, "\nextern void return_complex_alpha(complex);" );
#elif	defined(__hp9000s700__)
      fprintf( ou, "\n" );
      fprintf( ou, "\ntypedef union { complex c; double d; fint i[2]; } u_hp9000s700;" );
#elif	defined(__mips__)
      fprintf( ou, "\n" );
      fprintf( ou, "\nextern void return_complex_mips(complex *);" );
#elif	defined(__sgi__)
      fprintf( ou, "\n" );
      fprintf( ou, "\nextern void return_complex_mips(complex *);" );
#endif
      header = 1;
      fprintf( ou, "\n" );
   }
/*
 * STEP 2.
 *
 * Declare the procedure called from Fortran.
 */
   fname();
   comma = 0;
   ns = strlen(fnam) + 1;
   switch(ftype) {
/*
 * Simple subroutine, no problem.
 */
      case 0: {
         fprintf( ou, "\nvoid %s(", fnam ); ns += 4;
         break;
      }
/*
 * Integer function, no problem since fint is chosen so that it has the
 * same number of bytes as the fortran integer
 */
      case 2: {
         fprintf( ou, "\nfint %s(", fnam ); ns += 4;
         break;
      }
/*
 * Logical function, no problem since this is in fact an integer function.
 * (Sorry, but HP thinks different! on some systems!!!)
 */
      case 3: {
#if	defined(__hp9000s800__)
         fprintf( ou, "\nchar %s(", fnam ); ns += 4;
#else
         fprintf( ou, "\nbool %s(", fnam ); ns += 4;
#endif
         break;
      }
/*
 * Special things have to be done for fortran character functions.
 * Each operating system has its own funny way of passing on the
 * length of the character function.
 */
      case 4: {
         fprintf( ou, "\nvoid %s(", fnam ); ns += 4;
         break;
      }
/*
 * Here the SUN acts very strange with floats. Since all math ops are
 * done in double precision, the SUN compiler replaces all floats
 * with doubles (except for pointers).
 * Also convex and hp9000s700 do weird things.
 */
      case 5: {
#if	defined(__convex__)
         fprintf( ou, "\nfint %s(", fnam ); ns += 4;
#elif	defined(__hp9000s700__)
         fprintf( ou, "\nfint %s(", fnam ); ns += 4;
#elif	defined(__sun__)
         fprintf( ou, "\nFLOATFUNCTIONTYPE %s(", fnam ); ns += 17;
#else
         fprintf( ou, "\nfloat %s(", fnam ); ns += 5;
#endif
         break;
      }
/*
 * Complex numbers is a problem. Each machine has its own problems.
 */
      case 6: {
#if	defined(__alliant__)
         fprintf( ou, "\nvoid %s(", fnam ); ns += 4;
#elif	defined(__hp9000s700__)
         fprintf( ou, "\nu_hp9000s700 %s(", fnam ); ns += 12;
#elif	defined(__vms__)
         fprintf( ou, "\ndouble %s(", fnam ); ns += 6;
#else
         fprintf( ou, "\nvoid %s(", fnam ); ns += 4;
#endif
         break;
      }
/*
 * Double precision function. No problems except for HP9000S700.
 */
      case 7: {
#if	defined(__hp9000s700__)
         fprintf( ou, "\nu_hp9000s700 %s(", fnam ); ns += 12;
#else
         fprintf( ou, "\ndouble %s(", fnam ); ns += 6;
#endif
         break;
      }

      case 13: {
         fprintf( ou, "\nfint8 %s(", fnam ); ns += 5;
         break;
      }

/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
   for (n = 0; n < ns; spaces[n++] = ' '); spaces[n] = 0;	/* make offset */
/*
 * On some machines there are functions which need extra arguments.
 * That is done below.
 */
   switch(ftype) {			/* now do the argument declarations */
/*
 * Integer function. No problem.
 */
      case 2: {
         break;
      }
/*
 * Logical function. No problem.
 */
      case 3: {
         break;
      }
/*
 * Character function. The general idea is that an extra character pointer
 * and an integer are added to the argument list. Exceptions are ALLIANT
 * and VMS.
 */
      case 4: {
#if	defined(__alliant__)
#elif	defined(__vms__)
         fprintf( ou, "struct dsc$descriptor_s *a0" ); comma = 1;
#else
         fprintf( ou, "char *a0,\n %sfint l0", spaces ); comma = 1;
#endif
         break;
      }
/*
 * Real function. No problem.
 */
      case 5: {
         break;
      }
/*
 * Complex function.
 */
      case 6: {
#if   defined(__F2C__)
         fprintf( ou, "complex *a0" ); comma = 1;
#elif	defined(__convex__)
         fprintf( ou, "complex *a0" ); comma = 1;
#elif	defined(__hp9000s300__)
         fprintf( ou, "complex *a0" ); comma = 1;
#elif	defined(__hp9000s800__)
         fprintf( ou, "complex *a0" ); comma = 1;
#elif	defined(__sony__)
         fprintf( ou, "complex *a0" ); comma = 1;
#elif	defined(__sun__)
         fprintf( ou, "complex *a0" ); comma = 1;
#endif
         break;
      }
/*
 * Double precision function. No problem.
 */
      case 7: {
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * Next we place the arguments.
 */
   if ((nargs == 0) && (!comma)) fprintf( ou, "void" );
   for (n = 0; n < nargs; n++ ) {
      if (!comma) comma = 1; else fprintf( ou, ",\n %s", spaces );
      switch(args[n]) {
/*
 * Integer argument.
 */
         case 2: {
            fprintf( ou, "fint *a%d", n+1 );
            break;
         }
/*
 * Logical argument.
 */
         case 3: {
            fprintf( ou, "bool *a%d", n+1 );
            break;
         }
/*
 * Character argument. Different for VMS.
 */
         case 4: {
#if	defined(__vms__)
            fprintf( ou, "struct dsc$descriptor_s *a%d", n+1 );
#else
            fprintf( ou, "char *a%d", n+1 );
#endif
            break;
         }
/*
 * Real argument.
 */
         case 5: {
            fprintf( ou, "float *a%d", n+1 );
            break;
         }
/*
 * Complex argument.
 */
         case 6: {
            fprintf( ou, "complex *a%d", n+1 );
            break;
         }
/*
 * Double precision argument.
 */
         case 7: {
            fprintf( ou, "double *a%d", n+1 );
            break;
         }
/*
 * fint8 argument.
 */
         case 13: {
            fprintf( ou, "fint8 *a%d", n+1 );
            break;
         }
/*
 * We shouldn't get here.
 */
         default: {
            break;
         }
      }
   }
/*
 * In general, when there are some character strings in the argument list,
 * the length of the string is found in an extra argument. They are
 * placed below. ALLIANT and VMS are here the exceptions.
 */
#if	defined(__alliant__)
#elif	defined(__vms__)
#else
   for (n = 0; n < nargs; n++ ) {
      if (args[n] == 4) {
         if (!comma) comma = 1; else fprintf( ou, ",\n %s", spaces );
         fprintf( ou, "fint l%d", n+1 );
      }
   }
#endif
   fprintf( ou, ")" );
/*
 * STEP 3.
 *
 * Generate the code.
 */
   fprintf( ou, "\n{" );	/* now generate the body of the F2C routine */
   cname();			/* do the necessary declarations */
   hname();			/* generate the definition file */
/*
 * Now declare the procedure to be called. This declaration is also
 * written to the *.h file, which can be included by applications which
 * want to use the procedure.
 */
   if ((df = fopen( hnam, "w")) == NULL) {
      fprintf( stderr, "[f2cvv] Cannot open %s\n", hnam );
      exit(EXIT_FAILURE);
   } else {
      printf( "%s\n", hnam );
   }
   comma = 0;
   switch(ftype) {
/*
 * Subroutine.
 */
      case 0: {
         fprintf( ou, "\n   void %s(", cnam );
         fprintf( df, "extern void %s(", cnam );
         break;
      }
/*
 * Integer function.
 */
      case 2: {
         fprintf( ou, "\n   fint %s(", cnam );
         fprintf( df, "extern fint %s(", cnam );
         break;
      }
/*
 * Logical function.
 */
      case 3: {
         fprintf( ou, "\n   bool %s(", cnam );
         fprintf( df, "extern bool %s(", cnam );
         break;
      }
/*
 * Character function.
 */
      case 4: {
         fprintf( ou, "\n   void %s(fchar", cnam );
         fprintf( df, "extern void %s(fchar", cnam );
         comma = 1;
         break;
      }
/*
 * Real function.
 */
      case 5: {
         fprintf( ou, "\n   float %s(", cnam );
         fprintf( df, "extern float %s(", cnam );
         break;
      }
/*
 * Complex function.
 */
      case 6: {
         fprintf( ou, "\n   complex %s(", cnam );
         fprintf( df, "extern complex %s(", cnam );
         break;
      }
/*
 * Double precision function.
 */
      case 7: {
         fprintf( ou, "\n   double %s(", cnam );
         fprintf( df, "extern double %s(", cnam );
         break;
      }
/*
 * fint8 function.
 */
      case 13: {
         fprintf( ou, "\n   fint8 %s(", cnam );
         fprintf( df, "extern fint8 %s(", cnam );
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * Now put the arguments in place.
 */
   if ((nargs == 0) && (!comma)) {
      fprintf( ou, "void" );
      fprintf( df, "void" );
   }
   for (n = 0; n < nargs; n++ ) {
      if (!comma) comma = 1; else {
         fprintf( ou, "," );
         fprintf( df, "," );
      }
      switch(args[n]) {
/*
 * Integer argument.
 */
         case 2: {
            fprintf( ou, "fint *" );
            fprintf( df, "fint *" );
            break;
         }
/*
 * Logical argument.
 */
         case 3: {
            fprintf( ou, "bool *" );
            fprintf( df, "bool *" );
            break;
         }
/*
 * Character argument.
 */
         case 4: {
            fprintf( ou, "fchar" );
            fprintf( df, "fchar" );
            break;
         }
/*
 * Real argument.
 */
         case 5: {
            fprintf( ou, "float *" );
            fprintf( df, "float *" );
            break;
         }
/*
 * Complex argument.
 */
         case 6: {
            fprintf( ou, "complex *" );
            fprintf( df, "complex *" );
            break;
         }
/*
 * Double precision argument.
 */
         case 7: {
            fprintf( ou, "double *" );
            fprintf( df, "double *" );
            break;
         }
/*
 * fint8 argument.
 */
         case 13: {
            fprintf( ou, "fint8 *" );
            fprintf( df, "fint8 *" );
            break;
         }
/*
 * We shouldn't get here.
 */
         default: {
            break;
         }
      }
   }
   fprintf( ou, ");" );
   fprintf( df, ");" );
   fprintf( df, "\n" ); fclose( df );
/*
 * Some procedures need an extra variable, Their declarations are put
 * out below.
 */
   switch(ftype) {
/*
 * Subroutine. No problem.
 */
      case 0: {
         break;
      }
/*
 * Integer function. No problem.
 */
      case 2: {
         break;
      }
/*
 * Logical function. No problem.
 */
      case 3: {
         break;
      }
/*
 * Character function. The same for all machines.
 */
      case 4: {
         fprintf( ou, "\n   fchar b0;" );
         break;
      }
/*
 * Real function. Different for CONVEX, HP9000S700 and SUN.
 */
      case 5: {
#if	defined(__convex__)
         fprintf( ou, "\n   float f;" );
#elif	defined(__hp9000s700__)
         fprintf( ou, "\n   float f;" );
#elif	defined(__sun__)
         fprintf( ou, "\n   float f;" );
#endif
         break;
      }
/*
 * Complex function. Different for AIX, ALPHA, HP9000S700, MIPS, SGI and VMS.
 */
      case 6: {
#if	defined(__aix__)
         fprintf( ou, "\n   complex cmplx;" );
#elif	defined(__alpha__)
         fprintf( ou, "\n   complex cmplx;" );
#elif	defined(__hp9000s700__)
         fprintf( ou, "\n   u_hp9000s700 u;" );
#elif	defined(__mips__)
         fprintf( ou, "\n   complex cmplx;" );
#elif	defined(__sgi__)
         fprintf( ou, "\n   complex cmplx;" );
#elif	defined(__vms__)
         fprintf( ou, "\n   union { complex c; double d; } cmplx;" );
#endif
         break;
      }
/*
 * Double precision function. No problem except for HP9000S700.
 */
      case 7: {
#if	defined(__hp9000s700__)
         fprintf( ou, "\n   u_hp9000s700 u;" );
#endif
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * All character strings need a declaration.
 */
   for (n = 0; n < nargs; n++ ) {
      if (args[n] == 4) fprintf( ou, "\n   fchar b%d;", n + 1);
   }
/*
 * Next we do some assignments prior to the call of the C procedure.
 */
   switch(ftype) {
/*
 * Subroutine. No problem.
 */
      case 0: {
         break;
      }
/*
 * Integer function. No problem.
 */
      case 2: {
         break;
      }
/*
 * Logical function. No problem.
 */
      case 3: {
         break;
      }
/*
 * Character function. Different for ALLIANT and VMS.
 */
      case 4: {
#if	defined(__alliant__)
         fprintf( ou, "\n   b0.a = a_alliant(0);");
         fprintf( ou, "\n   b0.l = l_alliant(0);");
#elif	defined(__vms__)
         fprintf( ou, "\n   b0.a = a0->dsc$a_pointer;");
         fprintf( ou, "\n   b0.l = a0->dsc$w_length;");
#else
         fprintf( ou, "\n   b0.a = a0;");
         fprintf( ou, "\n   b0.l = l0;");
#endif
         break;
      }
/*
 * Real function. No problem.
 */
      case 5: {
         break;
      }
/*
 * Complex function. No problem.
 */
      case 6: {
         break;
      }
/*
 * Double precision function. No problem.
 */
      case 7: {
         break;
      }
/*
 * fint8 function. No problem.
 */
      case 13: {
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * Now we have to assign some arguments.
 */
   for (n = 0; n < nargs; n++ ) {
      switch(args[n]) {
/*
 * Integer argument. No problem.
 */
         case 2: {
            break;
         }
/*
 * Logical argument. No problem.
 */
         case 3: {
            break;
         }
/*
 * Character argument. Different for ALLIANT and VMS.
 */
         case 4: {
#if	defined(__alliant__)
            fprintf( ou, "\n   b%d.a = a_alliant(%d);", n+1, n+1 );
            fprintf( ou, "\n   b%d.l = l_alliant(%d);", n+1, n+1 );
#elif	defined(__vms__)
            fprintf( ou, "\n   b%d.a = a%d->dsc$a_pointer;", n+1, n+1 );
            fprintf( ou, "\n   b%d.l = a%d->dsc$w_length;", n+1, n+1 );
#else
            fprintf( ou, "\n   b%d.a = a%d;", n+1, n+1 );
            fprintf( ou, "\n   b%d.l = l%d;", n+1, n+1 );
#endif
            break;
         }
/*
 * Real argument. No problem.
 */
         case 5: {
            break;
         }
/*
 * Complex argument. No problem.
 */
         case 6: {
            break;
         }
/*
 * Double precision argument. No problem.
 */
         case 7: {
            break;
         }
/*
 * fint8 argument. No problem.
 */
         case 13: {
            break;
         }
/*
 * We shouldn't get here.
 */
         default: {
            break;
         }
      }
   }
/*
 * Here the call to the C routine is generated
 */
   comma = 0;
   switch(ftype) {
/*
 * Subroutine call. No problem.
 */
      case 0: {
         fprintf( ou, "\n   %s(", cnam );
         break;
      }
/*
 * Integer function call. No problem.
 */
      case 2: {
         fprintf( ou, "\n   return(%s(", cnam );
         break;
      }
/*
 * Logical function call. No problem, except for some HP's.
 */
      case 3: {
#if	defined(__hp9000s800__)
         fprintf( ou, "\n   return((%s(", cnam );
#else
         fprintf( ou, "\n   return(%s(", cnam );
#endif
         break;
      }
/*
 * Character function call. No problem.
 */
      case 4: {
         fprintf( ou, "\n   %s(b0", cnam ); comma = 1;
         break;
      }
/*
 * Real function call. No problem, except for CONVEX, HP9000S700 and SUN.
 */
      case 5: {
#if	defined(__convex__)
         fprintf( ou, "\n   f = %s(", cnam );
#elif	defined(__hp9000s700__)
         fprintf( ou, "\n   f = %s(", cnam );
#elif	defined(__sun__)
         fprintf( ou, "\n   f = %s(", cnam );
#else
         fprintf( ou, "\n   return(%s(", cnam );
#endif
         break;
      }
/*
 * Complex function call. Each machine has its own ideas.
 */
      case 6: {
#if	defined(__aix__)
         fprintf( ou, "\n   cmplx = %s(", cnam );
#elif	defined(__alliant__)
         fprintf( ou, "\n   return_complex_alliant(%s(", cnam );
#elif	defined(__alpha__)
         fprintf( ou, "\n   cmplx = %s(", cnam );
#elif	defined(__hp9000s700__)
         fprintf( ou, "\n   u.c =%s(", cnam );
#elif	defined(__mips__)
         fprintf( ou, "\n   cmplx = %s(", cnam );
#elif	defined(__sgi__)
         fprintf( ou, "\n   cmplx = %s(", cnam );
#elif	defined(__vms__)
         fprintf( ou, "\n   cmplx.c = %s(", cnam );
#else
         fprintf( ou, "\n   *a0 = %s(", cnam );
#endif
         break;
      }
/*
 * Double precision function call. No problem except for HP9000S700.
 */
      case 7: {
#if	defined(__hp9000s700__)
         fprintf( ou, "\n   u.d =%s(", cnam );
#else
         fprintf( ou, "\n   return(%s(", cnam );
#endif
         break;
      }
/*
 * fint8 function call. No problem.
 */
      case 13: {
         fprintf( ou, "\n   return(%s(", cnam );
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * Now put out the arguments in the call.
 */
   for (n = 0; n < nargs; n++ ) {
      if (!comma) comma = 1; else fprintf( ou, ",");
      if (args[n] == 4) {
         fprintf( ou, "b%d", n+1 );
      } else {
         fprintf( ou, "a%d", n+1 );
      }
   }
/*
 * Now close the call to the C routine.
 */
   switch(ftype) {
/*
 * Subroutine call. No problem.
 */
      case 0: {
         fprintf( ou, ");" );
         break;
      }
/*
 * Integer function call. No problem.
 */
      case 2: {
         fprintf( ou, "));" );
         break;
      }
/*
 * Logical function call. No problem, except for some HP's.
 */
      case 3: {
#if	defined(__hp9000s800__)
         fprintf( ou, ") >> 24) & 1);" );
#else
         fprintf( ou, "));" );
#endif
         break;
      }
/*
 * Character function call. No problem.
 */
      case 4: {
         fprintf( ou, ");" );
         break;
      }
/*
 * Real function call. No problem, except for CONVEX, HP9000S700 and SUN.
 */
      case 5: {
#if	defined(__convex__)
         fprintf( ou, ");\n   return(*((fint *)&f));" );
#elif	defined(__hp9000s700__)
         fprintf( ou, ");\n   return(*((fint *)&f));" );
#elif	defined(__sun__)
         fprintf( ou, ");\n   RETURNFLOAT(f);" );
#else
         fprintf( ou, "));" );
#endif
         break;
      }
/*
 * Complex function call. Each machine thinks different about this.
 */
      case 6: {
#if	defined(__aix__)
         fprintf( ou, ");\n   return_complex_aix(cmplx);" );
#elif	defined(__alliant__)
         fprintf( ou, "));" );
#elif	defined(__alpha__)
         fprintf( ou, ");\n   return_complex_alpha(cmplx);" );
#elif	defined(__hp9000s700__)
         fprintf( ou, ");\n   return(u);" );
#elif	defined(__mips__)
         fprintf( ou, ");\n   return_complex_mips(&cmplx);" );
#elif	defined(__sgi__)
         fprintf( ou, ");\n   return_complex_mips(&cmplx);" );
#elif	defined(__vms__)
         fprintf( ou, ");\n   return(cmplx.d);" );
#else
         fprintf( ou, ");" );
#endif
         break;
      }
/*
 * Double precision function call. No problem except for HP9000S700.
 */
      case 7: {
#if	defined(__hp9000s700__)
         fprintf( ou, ");\n   return(u);" );
#else
         fprintf( ou, "));" );
#endif
         break;
      }
/*
 * fint8 function call. No problem.
 */
      case 13: {
         fprintf( ou, "));" );
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * end of C routine body
 */
   fprintf( ou, "\n}\n" );
}


static	void	encode_ctof( void )
/*
 * This routine generates the source code for the C to F interface.
 * This routine is system dependent!
 */
{
   int	n;
   int	comma;

   comma = 0;
   if (!header) {                           /* print header of output file */
      if ((ou = fopen( ouname, "w")) == NULL) {
         fprintf( stderr, "[f2cvv] Error opening %s\n", ouname );
         exit(EXIT_FAILURE);
      }
      fprintf( ou, "/%c ANSI C2F interface generated for %s by program f2cvv %c/", '*', onam, '*' );
#if	defined(__sun__)
      fprintf( ou, "\n" );
      fprintf( ou, "\n#if defined(mc68000) | defined(__mc68000__)" );
      fprintf( ou, "\n#define FLOATFUNCTIONTYPE       int" );
      fprintf( ou, "\n#define RETURNFLOAT(x)          return (*(int *)(&(x)))" );
      fprintf( ou, "\n#define ASSIGNFLOAT(x,y)        *(int *)(&x) = y" );
      fprintf( ou, "\n#endif" );
      fprintf( ou, "\n#if defined(sparc) | defined(__sparc__)" );
      fprintf( ou, "\n#define FLOATFUNCTIONTYPE       double" );
      fprintf( ou, "\n#define RETURNFLOAT(x)          { union {double _d ; float _f ; } _kluge ; _kluge._f = (x) ; return _kluge._d ; }" );
      fprintf( ou, "\n#define ASSIGNFLOAT(x,y)        { union {double _d ; float _f ; } _kluge ; _kluge._d = (y) ; x = _kluge._f ; }" );
      fprintf( ou, "\n#endif" );
      fprintf( ou, "\n#if defined(i386) | defined(__i386__)" );
      fprintf( ou, "\n#define FLOATFUNCTIONTYPE       float" );
      fprintf( ou, "\n#define RETURNFLOAT(x)          return (x)" );
      fprintf( ou, "\n#define ASSIGNFLOAT(x,y)        x = y" );
      fprintf( ou, "\n#endif" );
#elif	defined(__vms__)
      fprintf( ou, "\n" );
      fprintf( ou, "\n#include <descrip.h>" );
#endif
      f2cvvdefs( ou, 0 );
#if	defined(__aix__)
      fprintf( ou, "\n" );
      fprintf( ou, "\ndouble fcall_complex_aix(double *);" );
#elif	defined(__alliant__)
      /*
       * For the ALLIANT a lot of special routines are necessary to
       * pass the arguments correctly to the FORTRAN routine.
       */
      fprintf( ou, "\n" );
      fprintf( ou, "\nvoid    fcall_void_alliant(void(),fint *);" );
      fprintf( ou, "\nfint    fcall_int_alliant(fint(),fint *);" );
      fprintf( ou, "\nbool    fcall_bool_alliant(bool(),fint *);" );
      fprintf( ou, "\nvoid    fcall_void_alliant(void(),fint *);" );
      fprintf( ou, "\nfloat   fcall_float_alliant(float(),fint *);" );
      fprintf( ou, "\ndouble  fcall_complex_alliant(complex(),fint *);" );
      fprintf( ou, "\ndouble  fcall_double_alliant(double(),fint *);" );
#elif	defined(__alpha__)
      fprintf( ou, "\n" );
      fprintf( ou, "\ndouble fcall_complex_alpha(double);" );
#elif	defined(__hp9000s700__)
      fprintf( ou, "\n" );
      fprintf( ou, "\ntypedef union { complex c; double d; fint i[2]; } u_hp9000s700;" );
#elif	defined(__mips__)
      fprintf( ou, "\n" );
      fprintf( ou, "\ndouble fcall_complex_mips(double);" );
#elif	defined(__sgi__)
      fprintf( ou, "\n" );
      fprintf( ou, "\ndouble fcall_complex_mips(double);" );
#endif
      header = 1;
      fprintf( ou, "\n" );
   }
   cname();			/* now generate procedure called from C */
   hname();			/* create definition file */
   if ((df = fopen( hnam, "w" )) == NULL) {
      fprintf( stderr,  "[f2cvv] Cannot open %s\n", hnam );
      exit(EXIT_FAILURE);
   } else {
      printf( "%s\n", hnam );
   }
   comma = 0;
/*
 * Declare the procedure.
 */
   switch(ftype) {
      case 0: {
         fprintf( ou, "\nvoid %s(", cnam );
         fprintf( df, "extern void %s(", cnam );
         break;
      }
      case 2: {
         fprintf( ou, "\nfint %s(", cnam );
         fprintf( df, "extern fint %s(", cnam );
         break;
      }
      case 3: {
         fprintf( ou, "\nbool %s(", cnam );
         fprintf( df, "extern bool %s(", cnam );
         break;
      }
      case 4: {
         fprintf( ou, "\nvoid %s(fchar a0", cnam );
         fprintf( df, "extern void %s(fchar", cnam );
         comma = 1;
         break;
      }
      case 5: {
         fprintf( ou, "\nfloat %s(", cnam );
         fprintf( df, "extern float %s(", cnam );
         break;
      }
      case 6: {
         fprintf( ou, "\ncomplex %s(", cnam );
         fprintf( df, "extern complex %s(", cnam );
         break;
      }
      case 7: {
         fprintf( ou, "\ndouble %s(", cnam );
         fprintf( df, "extern double %s(", cnam );
         break;
      }
      case 13: {
         fprintf( ou, "\nfint8 %s(", cnam );
         fprintf( df, "extern fint8 %s(", cnam );
         break;
      }
      default: break;
   }
   if ((nargs == 0) && (!comma)) {
      fprintf( ou, "void" );
      fprintf( df, "void" );
   }
   for (n = 0; n < nargs; n++) {
      if (!comma) comma = 1; else {
         fprintf( ou, "," );
         fprintf( df, "," );
      }
      switch(args[n]) {
         case 2: {
            fprintf( ou, "fint *a%d", n+1 );
            fprintf( df, "fint *" );
            break;
         }
         case 3: {
            fprintf( ou, "bool *a%d", n+1 );
            fprintf( df, "bool *" );
            break;
         }
         case 4: {
            fprintf( ou, "fchar a%d", n+1 );
            fprintf( df, "fchar" );
            break;
         }
         case 5: {
            fprintf( ou, "float *a%d", n+1 );
            fprintf( df, "float *" );
            break;
         }
         case 6: {
            fprintf( ou, "complex *a%d", n+1 );
            fprintf( df, "complex *" );
            break;
         }
         case 7: {
            fprintf( ou, "double *a%d", n+1 );
            fprintf( df, "double *" );
            break;
         }
         case 13: {
            fprintf( ou, "fint8 *a%d", n+1 );
            fprintf( df, "fint8 *" );
            break;
         }
         default: break;
      }
   }
   fprintf( ou, ")" );
   fprintf( df, ");" );
   fprintf( df, "\n" ); fclose( df );
   fprintf( ou, "\n{" );	/* now generate the body of the C2F routine */
   fname();			/* do the necessary declarations */
   comma = 0;
/*
 * Declare the Fortran procedure.
 */
   switch(ftype) {
/*
 * Subroutine. No problem.
 */
      case 0: {
         fprintf( ou, "\n   void %s(", fnam );
         break;
      }
/*
 * Integer function. No problem.
 */
      case 2: {
         fprintf( ou, "\n   fint %s(", fnam );
         break;
      }
/*
 * Logical function. Problems for some HP's.
 */
      case 3: {
#if	defined(__hp9000s800__)
         fprintf( ou, "\n   char %s(", fnam );
#else
         fprintf( ou, "\n   bool %s(", fnam );
#endif
         break;
      }
/*
 * Character function. Problems for ALLIANT and VMS.
 */
      case 4: {
#if	defined(__alliant__)
         fprintf( ou, "\n   void %s(", fnam );
#elif	defined(__vms__)
         fprintf( ou, "\n   void %s(struct dsc$descriptor *", fnam ); comma = 1;
#else
         fprintf( ou, "\n   void %s(char *,fint", fnam ); comma = 1;
#endif
         break;
      }
/*
 * Real function. Problems for CONVEX and SUN.
 */
      case 5: {
#if	defined(__convex__)
         fprintf( ou, "\n   fint %s(", fnam );
#elif	defined(__sun__)
         fprintf( ou, "\n   FLOATFUNCTIONTYPE %s(", fnam );
#else
         fprintf( ou, "\n   float %s(", fnam );
#endif
         break;
      }
/*
 * Complex function. What a mess.
 */
      case 6: {
#if	defined(__aix__)
         fprintf( ou, "\n   double *%s(", fnam );
#elif	defined(__alliant__)
         fprintf( ou, "\n   complex %s(", fnam );
#elif	defined(__alpha__)
         fprintf( ou, "\n   double %s(", fnam );
#elif	defined(__hp9000s700__)
         fprintf( ou, "\n   u_hp9000s700 %s(", fnam );
#elif	defined(__hp9000s800__)
         fprintf( ou, "\n   complex %s(", fnam );
#elif	defined(__mips__)
         fprintf( ou, "\n   double %s(", fnam );
#elif	defined(__sgi__)
         fprintf( ou, "\n   double %s(", fnam );
#elif	defined(__vms__)
         fprintf( ou, "\n   double %s(", fnam );
#else
         fprintf( ou, "\n   void %s(complex *", fnam ); comma = 1;
#endif
         break;
      }
/*
 * Double precision function. No problem.
 */
      case 7: {
         fprintf( ou, "\n   double %s(", fnam );
         break;
      }
/*
 * fint8 function. No problem.
 */
      case 13: {
         fprintf( ou, "\n   fint8 %s(", fnam );
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * Now we put in the arguments.
 */
   if ((nargs == 0) && (!comma)) fprintf( ou, "void" );
   for (n = 0; n < nargs; n++) {
      if (!comma) comma = 1; else fprintf( ou, "," );
      switch(args[n]) {
/*
 * Integer argument.
 */
         case 2: {
            fprintf( ou, "fint *" );
            break;
         }
/*
 * Logical argument.
 */
         case 3: {
            fprintf( ou, "bool *" );
            break;
         }
/*
 * Character argument. Different for VMS.
 */
         case 4: {
#if	defined(__vms__)
            fprintf( ou, "struct dsc$descriptor *" );
#else
            fprintf( ou, "char *" );
#endif
            break;
         }
/*
 * Real argument.
 */
         case 5: {
            fprintf( ou, "float *" );
            break;
         }
/*
 * Complex argument. Different for ALPHA, HP9000S700, MIPS and SGI.
 */
         case 6: {
#if	defined(__alpha__)
            fprintf( ou, "double *" );
#elif	defined(__mips__)
            fprintf( ou, "double *" );
#elif	defined(__sgi__)
            fprintf( ou, "double *" );
#elif	defined(__hp9000s700__)
#else
            fprintf( ou, "complex *" );
#endif
            break;
         }
/*
 * Double precision argument.
 */
         case 7: {
            fprintf( ou, "double *" );
            break;
         }
/*
 * fint8 argument.
 */
         case 13: {
            fprintf( ou, "fint8 *" );
            break;
         }
/*
 * We shouldn't get here.
 */
         default: {
            break;
         }
      }
   }
/*
 * Create the extra arguments for length of character strings.
 * Not for ALLIANT and VMS.
 */

#if	defined(__alliant__)
#elif	defined(__vms__)
#else
   for (n = 0; n < nargs; n++) {
      if (args[n] == 4) {
         if (!comma) comma = 1; else fprintf( ou, "," );
         fprintf( ou, "fint" );
      }
   }
#endif
   fprintf( ou, ");" );

/*
 * Declare some variables needed for the functions.
 */
   switch(ftype) {
/*
 * Subroutine.
 */
      case 0: {
         break;
      }
/*
 * Integer function.
 */
      case 2: {
         break;
      }
/*
 * Logical function.
 */
      case 3: {
         break;
      }
/*
 * Character function.
 */
      case 4: {
#if	defined(__vms__)
         fprintf( ou, "\n   struct dsc$descriptor_s b0;" );
#endif
         break;
      }
/*
 * Real function.
 */
      case 5: {
#if	defined(__convex__)
         fprintf( ou, "\n   union { fint i; float f; } r;" );
#elif	defined(__sun__)
         fprintf( ou, "\n   float f;" );
#endif
         break;
      }
/*
 * Complex function.
 */
      case 6: {
#if   defined(__F2C__)
         fprintf( ou, "\n   complex c;" );
#elif	defined(__aix__)
         fprintf( ou, "\n   union { complex c; double d; } cmplx;" );
#elif	defined(__alliant__)
         fprintf( ou, "\n   union { complex c; double d; } cmplx;" );
#elif	defined(__alpha__)
         fprintf( ou, "\n   union { complex c; double d; } cmplx;" );
#elif	defined(__convex__)
         fprintf( ou, "\n   complex c;" );
#elif	defined(__hp9000s300__)
         fprintf( ou, "\n   complex c;" );
#elif	defined(__hp9000s700__)
         fprintf( ou, "\n   u_hp9000s700 u;" );
#elif	defined(__mips__)
         fprintf( ou, "\n   union { complex c; double d; } cmplx;" );
#elif	defined(__sgi__)
         fprintf( ou, "\n   union { complex c; double d; } cmplx;" );
#elif	defined(__sony__)
         fprintf( ou, "\n   complex c;" );
#elif	defined(__sun__)
         fprintf( ou, "\n   complex c;" );
#elif	defined(__vms__)
         fprintf( ou, "\n   union { complex c; double d; } cmplx;" );
#endif
         break;
      }
/*
 * Double precision function.
 */
      case 7: {
         break;
      }
/*
 * fint8 function.
 */
      case 13: {
         break;
      }
/*
 * We shouldn't get here.
 */
      default: {
         break;
      }
   }
/*
 * Next we define soma variables needed to make the call to the
 * Fortran routine. Only for ALLIANT and VMS.
 */
#if	defined(__alliant__)
   fprintf( ou, "\n   fint arg[%d];", nargs+nargs+3 );
#elif	defined(__vms__)
   for (n = 0; n < nargs; n++ ) {
      if (args[n] == 4) fprintf( ou, "\n   struct dsc$descriptor_s b%d;", n + 1);
   }
#endif

/*
 * Do the assignments to get the return value in the correct place.
 */
   switch(ftype) {
      case 0: {
#if	defined(__alliant__)
         fprintf( ou, "\n   arg[%d] = %d;", nargs+2, nargs );
#endif
         break;
      }
      case 2: {
#if	defined(__alliant__)
         fprintf( ou, "\n   arg[%d] = %d;", nargs+2, nargs );
#endif
         break;
      }
      case 3: {
#if	defined(__alliant__)
         fprintf( ou, "\n   arg[%d] = %d;", nargs+2, nargs );
#endif
         break;
      }
      case 4: {
#if	defined(__alliant__)
         fprintf( ou, "\n   arg[0] = (fint) &a0.l;");
         fprintf( ou, "\n   arg[1] = (fint)  a0.a;");
         fprintf( ou, "\n   arg[%d] = %d;", nargs+2, nargs + 131072 );
#elif	defined(__vms__)
         fprintf( ou, "\n   b0.dsc$a_pointer = a0.a;");
         fprintf( ou, "\n   b0.dsc$w_length  = a0.l;");
#endif
         break;
      }
      case 5: {
#if	defined(__alliant__)
         fprintf( ou, "\n   arg[%d] = %d;", nargs+2, nargs );
#endif
         break;
      }
      case 6: {
#if	defined(__alliant__)
         fprintf( ou, "\n   arg[%d] = %d;", nargs+2, nargs );
#endif
         break;
      }
      case 7: {
#if	defined(__alliant__)
         fprintf( ou, "\n   arg[%d] = %d;", nargs+2, nargs );
#endif
         break;
      }
      default: {
         break;
      }
   }
/*
 * Do the assignments for the arguments.
 */
   for (n = 0; n < nargs; n++ ) {
      switch(args[n]) {
         case 2: {
#if	defined(__alliant__)
            fprintf( ou, "\n   arg[%d] = 0;", n+2 );
            fprintf( ou, "\n   arg[%d] = (fint) a%d;", n+nargs+3 ,n+1 );
#endif
            break;
         }
         case 3: {
#if	defined(__alliant__)
            fprintf( ou, "\n   arg[%d] = 0;", n+2 );
            fprintf( ou, "\n   arg[%d] = (fint) a%d;", n+nargs+3 ,n+1 );
#endif
            break;
         }
         case 4: {
#if	defined(__alliant__)
            fprintf( ou, "\n   arg[%d] = (fint) &a%d.l;", n+2, n+1 );
            fprintf( ou, "\n   arg[%d] = (fint)  a%d.a;", n+nargs+3, n+1 );
#elif	defined(__vms__)
            fprintf( ou, "\n   b%d.dsc$a_pointer = a%d.a;", n+1, n+1 );
            fprintf( ou, "\n   b%d.dsc$w_length  = a%d.l;", n+1, n+1 );
#endif
            break;
         }
         case 5: {
#if	defined(__alliant__)
            fprintf( ou, "\n   arg[%d] = 0;", n+2 );
            fprintf( ou, "\n   arg[%d] = (fint) a%d;", n+nargs+3 ,n+1 );
#endif
            break;
         }
         case 6: {
#if	defined(__alliant__)
            fprintf( ou, "\n   arg[%d] = 0;", n+2 );
            fprintf( ou, "\n   arg[%d] = (fint) a%d;", n+nargs+3 ,n+1 );
#endif
            break;
         }
         case 7: {
#if	defined(__alliant__)
            fprintf( ou, "\n   arg[%d] = 0;", n+2 );
            fprintf( ou, "\n   arg[%d] = (fint) a%d;", n+nargs+3 ,n+1 );
#endif
            break;
         }
         default: {
            break;
         }
      }
   }
/*
 * Now generate the call to the C routine.
 * For the ALLIANT this is easy, since we have just built the argument
 * stack.
 */
   comma = 0;
   switch(ftype) {
      case 0: {
#if	defined(__alliant__)
         fprintf( ou, "\n   fcall_void_alliant(%s,&arg[%d]);", fnam, nargs+3 );
#else
         fprintf( ou, "\n   %s(", fnam );
#endif
         break;
      }
      case 2: {
#if	defined(__alliant__)
         fprintf( ou, "\n   return(fcall_int_alliant(%s,&arg[%d]));", fnam, nargs+3 );
#else
         fprintf( ou, "\n   return(%s(", fnam );
#endif
         break;
      }
      case 3: {
#if	defined(__alliant__)
         fprintf( ou, "\n   return(fcall_bool_alliant(%s,&arg[%d]));", fnam, nargs+3 );
#elif	defined(__hp9000s800__)
         fprintf( ou, "\n   return((%s(", fnam );
#else
         fprintf( ou, "\n   return(%s(", fnam );
#endif
         break;
      }
      case 4: {
#if	defined(__alliant__)
         fprintf( ou, "\n   fcall_void_alliant(%s,&arg[%d]);", fnam, nargs+3 );
#elif	defined(__vms__)
         fprintf( ou, "\n   %s(&b0", fnam ); comma = 1;
#else
         fprintf( ou, "\n   %s(a0.a,a0.l", fnam ); comma = 1;
#endif
         break;
      }
      case 5: {
#if	defined(__alliant__)
         fprintf( ou, "\n   return(fcall_float_alliant(%s,&arg[%d]));", fnam, nargs+3 );
#elif	defined(__convex__)
         fprintf( ou, "\n   r.i = %s(", fnam );
#elif	defined(__sun__)
         fprintf( ou, "\n   ASSIGNFLOAT(f,%s(", fnam );
#else
         fprintf( ou, "\n   return(%s(", fnam );
#endif
         break;
      }
      case 6: {
#if	defined(__F2C__)
         fprintf( ou, "\n   %s(&c", fnam ); comma = 1;
#elif	defined(__aix__)
         fprintf( ou, "\n   cmplx.d = fcall_complex_aix(%s(", fnam );
#elif	defined(__alliant__)
         fprintf( ou, "\n   cmplx.d = fcall_complex_alliant(%s,&arg[%d]);", fnam, nargs+3 );
#elif	defined(__alpha__)
         fprintf( ou, "\n   cmplx.d = fcall_complex_alpha(%s(", fnam );
#elif	defined(__convex__)
         fprintf( ou, "\n   %s(&c", fnam ); comma = 1;
#elif	defined(__hp9000s300__)
         fprintf( ou, "\n   %s(&c", fnam ); comma = 1;
#elif	defined(__hp9000s700__)
         fprintf( ou, "\n   u = %s(", fnam );
#elif	defined(__mips__)
         fprintf( ou, "\n   cmplx.d = fcall_complex_mips(%s(", fnam );
#elif	defined(__sgi__)
         fprintf( ou, "\n   cmplx.d = fcall_complex_mips(%s(", fnam );
#elif	defined(__sony__)
         fprintf( ou, "\n   %s(&c", fnam ); comma = 1;
#elif	defined(__sun__)
         fprintf( ou, "\n   %s(&c", fnam ); comma = 1;
#elif	defined(__vms__)
         fprintf( ou, "\n   cmplx.d = %s(", fnam );
#else
         fprintf( ou, "\n   return(%s(", fnam );
#endif
         break;
      }
      case 7: {
#if	defined(__alliant__)
         fprintf( ou, "\n   return(fcall_double_alliant(%s,&arg[%d]));", fnam, nargs+3 );
#else
         fprintf( ou, "\n   return(%s(", fnam );
#endif
         break;
      }
      case 13: {
         fprintf( ou, "\n   return(%s(", fnam );
         break;
      }
      default: {
         break;
      }
   }
/*
 * Next we put out the arguments to the call.
 */
   for (n = 0; n < nargs; n++ ) {
      if (comma) fprintf( ou, ",");
      switch(args[n]) {
         case 2: {
#if	defined(__alliant__)
#else
            fprintf( ou, "a%d", n+1 );
            comma = 1;
#endif
            break;
         }
         case 3: {
#if	defined(__alliant__)
#else
            fprintf( ou, "a%d", n+1 );
            comma = 1;
#endif
            break;
         }
         case 4: {
#if	defined(__alliant__)
#elif	defined(__vms__)
            fprintf( ou, "&b%d", n+1 );
            comma = 1;
#else
            fprintf( ou, "a%d.a", n+1 );
            comma = 1;
#endif
            break;
         }
         case 5: {
#if	defined(__alliant__)
#else
            fprintf( ou, "a%d", n+1 );
            comma = 1;
#endif
            break;
         }
         case 6: {
#if	defined(__alliant__)
#elif	defined(__alpha__)
            fprintf( ou, "(double *)a%d", n+1 );
            comma = 1;
#elif	defined(__mips__)
            fprintf( ou, "(double *)a%d", n+1 );
            comma = 1;
#elif	defined(__sgi__)
            fprintf( ou, "(double *)a%d", n+1 );
            comma = 1;
#else
            fprintf( ou, "a%d", n+1 );
            comma = 1;
#endif
            break;
         }
         case 7: {
#if	defined(__alliant__)
#else
            fprintf( ou, "a%d", n+1 );
            comma = 1;
#endif
            break;
         }
         case 13: {
            fprintf( ou, "a%d", n+1 );
            comma = 1;
            break;
         }
         default: {
            break;
         }
      }
   }
/*
 * Next we put out the extra argument for the character string lengths,
 * except for ALLIANT and VMS.
 */
#if	defined(__alliant__)
#elif	defined(__vms__)
#else
   for (n = 0; n < nargs; n++ ) {
      if (args[n] == 4) {
         if (!comma) comma = 1; else fprintf( ou, "," );
         fprintf( ou, "a%d.l", n+1 );
      }
   }
#endif
/*
 * Now we close the call to the Fortran routine.
 */
   switch(ftype) {
      case 0: {
#if	defined(__alliant__)
#else
         fprintf( ou, ");" );
#endif
         break;
      }
      case 2: {
#if	defined(__alliant__)
#else
         fprintf( ou, "));" );
#endif
         break;
      }
      case 3: {
#if	defined(__alliant__)
#elif	defined(__hp9000s800__)
         fprintf( ou, ") << 24) & 0x01000000);" );
#else
         fprintf( ou, "));" );
#endif
         break;
      }
      case 4: {
#if	defined(__alliant__)
#else
         fprintf( ou, ");" );
#endif
         break;
      }
      case 5: {
#if	defined(__alliant__)
#elif	defined(__convex__)
         fprintf( ou, ");\n   return(r.f);" );
#elif	defined(__sun__)
         fprintf( ou, "));\n   return(f);" );
#else
         fprintf( ou, "));" );
#endif
         break;
      }
      case 6: {
#if   defined(__F2C__)
         fprintf( ou, ");\n   return(c);" );
#elif	defined(__aix__)
         fprintf( ou, "));\n   return(cmplx.c);" );
#elif	defined(__alliant__)
         fprintf( ou, "\n   return(cmplx.c);" );
#elif	defined(__alpha__)
         fprintf( ou, "));\n   return(cmplx.c);" );
#elif	defined(__convex__)
         fprintf( ou, ");\n   return(c);" );
#elif	defined(__hp9000s300__)
         fprintf( ou, ");\n   return(c);" );
#elif	defined(__hp9000s700__)
         fprintf( ou, ");\n   return(u.c);" );
#elif	defined(__mips__)
         fprintf( ou, "));\n   return(cmplx.c);" );
#elif	defined(__sgi__)
         fprintf( ou, "));\n   return(cmplx.c);" );
#elif	defined(__sony__)
         fprintf( ou, ");\n   return(c);" );
#elif	defined(__sun__)
         fprintf( ou, ");\n   return(c);" );
#elif	defined(__vms__)
         fprintf( ou, ");\n   return(cmplx.c);" );
#else
         fprintf( ou, "));" );
#endif
         break;
      }
      case 7: {
#if	defined(__alliant__)
#else
         fprintf( ou, "));" );
#endif
         break;
      }
      case 13: {
         fprintf( ou, "));" );
         break;
      }
      default: {
         break;
      }
   }
/*
 * End of C routine body.
 */
   fprintf( ou, "\n}\n" );
}

int	main( int argc, char *argv[] )
/*
 * Main program.
 * Latest Update:  Nov 17, 1989, by K.G. Begeman
 */
{
   int	defs;
   int	iret;
   int	n, nc;

   if (!implemented()) {		/* See if we can run on this machine */
      fprintf( stderr, "[f2cvv] No F2C/C2F interface implemented for this machine\n");
      return(1);
   }
   if (argc < 2) {
      printf("Usage: %s filename [filename [..]]\n", argv[0] );
      return(0);
   }
   for (n = 1; n < argc; n++) {
      int ic = 0;
      defs = 0; ch = ' '; header = 0; pos = 0;
      nc = strlen(argv[n]);
      strcpy(inname, argv[n]);
/*
 * Find type of interface (F2C or C2F).
 * The extension of the file tells us which way we want to go.
 */
#if	defined(__vms__)
/*
 * VMS is not case sensitive!
 */
      {
         int lc;

         for (lc = 0; lc < nc; inname[lc] = tolower(inname[lc]), lc++);
      }
#endif
      for (ic = nc - 1; ic >= 0 && inname[ic] != '.'; ic--);
      if (ic < 0) {
         fprintf( stderr, "[f2cvv] No extension given\n" );
         return(1);
      }
      if (!strcmp(&inname[ic], ".c")) {		/* C source */
         ftoc = 1;
      } else if (!strcmp(&inname[ic], ".for")) {/* FORTRAN source */
         ftoc = 0;
      } else if (!strcmp(&inname[ic], ".f")) {	/* FORTRAN source */
         ftoc = 0;
      } else if (!strcmp(&inname[ic], ".shl")) {/* SHELTRAN source */
         ftoc = 0;
      } else if (!strcmp(&inname[ic], ".h" )) {	/* generate include file */
         defs = 1;
      } else {
         fprintf( stderr, "[f2cvv] Unknown extension %s\n", &inname[ic] );
         return(1);
      }
      if (defs) {
         strcpy( hnam, inname );
         if ((in = fopen( inname, "w")) == NULL) {
            fprintf( stderr, "[f2cvv] Cannot create definition file\n" );
            return(1);
         }
         f2cvvdefs( in, 1 );
      } else {
         if ((in = fopen( inname, "r" )) == NULL) {
            fprintf( stderr, "[f2cvv] Input file %s does not exist\n", inname );
            return(1);
         }
         inname[ic] = 0;
         strcpy(ouname,inname);
         if (ftoc) strcat(ouname,"_ftoc.c"); else strcat(ouname,"_ctof.c");
         while (!(iret = decode())) if (ftoc) encode_ftoc(); else encode_ctof();
         if (iret > 0) {
            switch(iret) {
               case 1: fprintf( stderr, "[f2cvv] Syntax error\n"); break;
               case 2: fprintf( stderr, "[f2cvv] Missing function type\n"); break;
               case 3: fprintf( stderr, "[f2cvv] Double precision ?\n"); break;
               case 4: fprintf( stderr, "[f2cvv] Function missing\n"); break;
               case 5: fprintf( stderr, "[f2cvv] Procedure name missing\n"); break;
               case 6: fprintf( stderr, "[f2cvv] ( missing\n"); break;
               case 7: fprintf( stderr, "[f2cvv] Unknown type\n"); break;
               case 8: fprintf( stderr, "[f2cvv] Argument buffer overflow\n"); break;
               case 9: fprintf( stderr, "[f2cvv] Illegal procedure name\n"); break;
               default: break;
            }
            return(1);
         }
      }
      fclose(in);
      if (header) fclose(ou);
   }
   return(0);
}

/*

+#!IF TESTBED
+
+#>    mainf.f
+      PROGRAM MAINF
+C
+C     Test program to test the F2C interface created by F2CVV.
+C
+C     The functions called by mainf are all in subc.c.
+C
+
+      CHARACTER*5      CC, RCC, ACC
+      DOUBLE PRECISION DC, RDC, ADC
+      INTEGER          IC, RIC, AIC
+      REAL             RC, RRC, ARC
+      LOGICAL          LC, RLC1, RLC2
+      COMPLEX          XC, RXC, AXC
+      INTEGER          COUNT
+
+      COUNT = 0
+      ACC = 'ABCDE'
+      ADC = 3.14152911D0
+      AIC = 32767
+      ARC = 2.17182844E0
+      AXC = CMPLX(1.0,2.0)
+      WRITE(*,*) ' Program to test the F2C interface,'//
+     :           ' Version 0.2 (Oct 12, 1989)'
+      RCC = CC(ACC)
+      IF (RCC .EQ. ACC) THEN
+         WRITE(*,*) ' character interface okay'
+         COUNT = COUNT + 1
+      ELSE
+         WRITE(*,*) ' character interface wrong:',ACC,'.ne.',RCC
+      ENDIF
+      RDC = DC(ADC)
+      IF (RDC .EQ. ADC) THEN
+         WRITE(*,*) ' double    interface okay'
+         COUNT = COUNT + 1
+      ELSE
+         WRITE(*,*) ' double    interface wrong:',ADC,'.ne.',RDC
+      ENDIF
+      RIC = IC(AIC)
+      IF (RIC .EQ. AIC) THEN
+         WRITE(*,*) ' integer   interface okay'
+         COUNT = COUNT + 1
+      ELSE
+         WRITE(*,*) ' integer   interface wrong:',AIC,'.ne.',RIC
+      ENDIF
+      RRC = RC(ARC)
+      IF (RRC .EQ. ARC) THEN
+         WRITE(*,*) ' real      interface okay'
+         COUNT = COUNT + 1
+      ELSE
+         WRITE(*,*)  'real      interface wrong:',ARC,'.ne.',RRC
+      ENDIF
+      RLC1 = LC(.TRUE.)
+      RLC2 = LC(.FALSE.)
+      IF (RLC1 .AND. .NOT.RLC2) THEN
+         WRITE(*,*) ' logical   interface okay'
+         COUNT = COUNT + 1
+      ELSE
+         WRITE(*,*) ' logical   interface wrong:',.TRUE.,'.ne.',RLC1,
+     :              ' or ',.FALSE.,'.ne.',RLC2
+      ENDIF
+      RXC = XC(AXC)
+      IF (RXC .EQ. AXC) THEN
+         WRITE(*,*) ' complex   interface okay'
+         COUNT = COUNT + 1
+      ELSE
+         WRITE(*,*) ' complex   interface wrong',AXC,'.ne.',RXC
+      ENDIF
+      WRITE(*,*) ' You scored',COUNT,' out of six'
+      IF (COUNT .EQ. 6) THEN
+         WRITE(*,*) ' NICE JOB!!'
+      ENDIF
+      STOP
+      END
+#<
+
+#>     subc.c
+#if 0
+Test routines for the F2C interface. This source should be linked
+with mainf.f. See mainf.f for further details.
+
+Definitions for F2C interface:
+
+ @ character function cc( character )
+ @ double precision function dc( double precision )
+ @ integer function ic( integer )
+ @ real function rc( real )
+ @ logical function lc( logical )
+ @ complex function xc( complex )
+
+#endif
+
+#include <stdio.h>
+#include "f2cvvdefs.h"
+
+void cc_c( a0, a1 )
+fchar a0, a1;
+{
+   char *p0, *p1;
+   int l0, l1;
+   int n;
+   p0 = a0.a; p1 = a1.a; l0 = a0.l; l1 = a1.l;
+   for (n = 0; n < l0 && n < l1; *p0++ = *p1++, n++);
+}
+
+double dc_c( a1 )
+double *a1;
+{
+   double d;
+   d = *a1;
+   return(d);
+}
+
+int ic_c( a1 )
+int *a1;
+{
+   int i;
+   i = *a1;
+   return(i);
+}
+
+float rc_c( a1 )
+float *a1;
+{
+   float f;
+   f = *a1;
+   return(f);
+}
+
+bool lc_c( a1 )
+bool *a1;
+{
+   bool b;
+   b = tobool( *a1 );
+   if (b) b = TRUE; else b = FALSE;
+   return(toflog(b));
+}
+
+complex xc_c( a1 )
+complex *a1;
+{
+   complex c;
+   c = *a1;
+   return(c);
+}
+#<
+
+#>    mainc.c
+#if 0
+Test program to test the C2F interface.
+The c program calls some fortran functions which can be found in
+subf.f
+
+GOOD LUCK!
+
+#endif
+
+#include <stdio.h>
+#include <string.h>
+#include "f2cvvdefs.h"
+
+#include "cc.h"
+#include "dc.h"
+#include "ic.h"
+#include "rc.h"
+#include "lc.h"
+#include "xc.h"
+
+void main()
+{
+   static fchar   a1, a2;
+   static fint    i1, i2;
+   static double  d1, d2;
+   static float   r1, r2;
+   static bool    b1, b2, dummy;
+   static complex c1, c2;
+   static char    text1[6], text2[6];
+   static int     count = 0;
+
+   printf("Program for testing the C2F interface, Version 0.2 (Oct 12, 1989)\n");
+   a1.a = text1; a2.a = text2; a1.l = 5; a2.l = 5;
+   strcpy(text2,"ABCDE");
+   cc_c( a1, a2 );
+   if (!strcmp(text1,text2)) {
+      printf("character interface okay\n");
+      count += 1;
+   } else {
+      printf("character interface wrong: %s.ne.%s\n",text1,text2);
+   }
+   d2 = 3.14152911;
+   d1 = dc_c( &d2 );
+   if (d1 == d2) {
+      printf("double    interface okay\n");
+      count += 1;
+   } else {
+      printf("double    interface wrong: %f.ne.%f\n",d1,d2);
+   }
+   i2 = 32767;
+   i1 = ic_c( &i2 );
+   if (i1 == i2) {
+      printf("integer   interface okay\n");
+      count += 1;
+   } else {
+      printf("integer   interface wrong: %d.ne.%d\n",i1,i2);
+   }
+   r2 = 2.17182844;
+   r1 = rc_c( &r2 );
+   if (r1 == r2) {
+      printf("real      interface okay\n");
+      count += 1;
+   } else {
+      printf("real      interface wrong: %f.ne.%f\n",r1,r2);
+   }
+   dummy = TRUE;
+   b1 = tobool(lc_c( &dummy ));
+   dummy = FALSE;
+   b2 = tobool(lc_c( &dummy ));
+   if ((b1) && (!b2)) {
+      printf("logical   interface okay\n");
+      count += 1;
+   } else {
+      printf("logical   interface wrong: %d.ne.1 or %d.ne.0\n",b1,b2);
+   }
+   c2.r = 10.0; c2.i = 11.0;
+   c1 = xc_c( &c2 );
+   if ((c1.r == c2.r) && (c1.i == c2.i)) {
+      printf("complex   interface okay\n");
+      count += 1;
+   } else {
+      printf("complex   interface wrong: (%f,%f).ne.(%f,%f)\n",
+      c1.r,c1.i,c2.r,c2.i);
+   }
+   printf("You scored %d out of 6\n",count);
+   if (count == 6) {
+      printf("WELL DONE\n");
+   } else {
+      printf("KEEP ON TRYING\n");
+   }
+}
+#<
+
+#>    subf.f
+C     Routines called by mainc.c to test the C2F interface.
+C
+C@    character function cc( character )
+C@    double precision function dc( double precision )
+C@    integer function ic( integer )
+C@    real function rc( real )
+C@    logical function lc( logical )
+C@    complex function xc( complex )
+      CHARACTER*(*) FUNCTION CC( A1 )
+      CHARACTER*(*) A1
+      CC = A1
+      RETURN
+      END
+      DOUBLE PRECISION FUNCTION DC( A1 )
+      DOUBLE PRECISION A1
+      DC = A1
+      RETURN
+      END
+      INTEGER FUNCTION IC( A1 )
+      INTEGER A1
+      IC = A1
+      RETURN
+      END
+      REAL FUNCTION RC( A1 )
+      REAL A1
+      RC = A1
+      RETURN
+      END
+      LOGICAL FUNCTION LC( A1 )
+      LOGICAL A1
+      IF (A1) THEN
+         LC = .TRUE.
+      ELSE
+         LC = .FALSE.
+      ENDIF
+      RETURN
+      END
+      COMPLEX FUNCTION XC( A1 )
+      COMPLEX A1
+      XC = A1
+      RETURN
+      END
+#<
+
+#>    Makefile
+#
+# makefile for testing f2cvv
+#
+#!IF     AIX
+AUX    = f2cvv_aux.o
+CC     = xlc -g
+CLIBS  =
+FC     = xlf -g
+FLIBS  =
+#!ELIF   ALLIANT
+AUX    = f2cvv_aux.o
+CC     = gcc -pedantic -ansi
+CLIBS  = -lfortran_p
+FC     = fortran
+FLIBS  =
+#!ELIF   ALPHA
+AUX    = f2cvv_aux.o
+CC     = cc
+CLIBS  = -lots
+FC     = f77
+FLIBS  =
+#!ELIF   CONVEX
+AUX    =
+CC     = cc -std
+CLIBS  = -lF77 -lI77 -lU77
+FC     = fc
+FLIBS  =
+#!ELIF   HPUX
+AUX    =
+#!IF     HP9000S700
+CC     = cc -Aa
+CLIBS  = -lf
+#!ELSE
+CC     = gcc -pedantic -ansi
+CLIBS  = -lI77 -lF77
+#!ENDIF
+FC     = f77
+FLIBS  =
+#!ELIF   MIPS
+AUX    = f2cvv_aux.o
+CC     = gcc -pedantic -ansi
+CLIBS  = -lF77 -lI77 -lU77
+FC     = f77
+FLIBS  =
+#!ELIF   SGI
+AUX    = f2cvv_aux.o
+CC     = cc -ansi
+CLIBS  = -lF77 -lI77 -lU77
+FC     = f77
+#!ELIF   SUN
+AUX    =
+CC     = gcc -pedantic -ansi
+CLIBS  = /usr/lang/SC0.0/libF77.a
+FC     = /usr/lang/f77
+FLIBS  =
+#!ENDIF
+
+default:: f2cvv mainf mainc
+
+clean::
+	rm -f f2cvv mainf mainc mainf.o mainc.o subf.o subf_ctof.o subf_ctof.c \
+	subc.o subc_ftoc.o subc_ftoc.c f2cvvdefs.h cc.h dc.h ic.h lc.h rc.h xc.h $(AUX)
+
+f2cvv: f2cvv.c
+	$(CC) -o f2cvv f2cvv.c
+
+mainf: mainf.o subc_ftoc.o subc.o $(AUX)
+	$(FC) -o mainf mainf.o subc.o subc_ftoc.o $(AUX) $(FLIBS)
+
+mainc: mainc.o subf_ctof.o subf.o $(AUX)
+	$(CC) -o mainc mainc.o subf.o subf_ctof.o $(AUX) $(CLIBS)
+
+#!IF     AIX
+f2cvv_aux.o: f2cvv_aux.s
+	as -o f2cvv_aux.o f2cvv_aux.s
+
+#!ELIF   ALLIANT
+f2cvv_aux.o: f2cvv_aux.s
+	as -o f2cvv_aux.o f2cvv_aux.s
+
+#!ELIF   ALPHA
+f2cvv_aux.o: f2cvv_aux.s
+	as -o f2cvv_aux.o f2cvv_aux.s
+
+#!ELIF   MIPS
+f2cvv_aux.o: f2cvv_aux.s
+	as -o f2cvv_aux.o f2cvv_aux.s
+
+#!ELIF   SGI
+f2cvv_aux.o: f2cvv_aux.s
+	as -o f2cvv_aux.o f2cvv_aux.s
+
+#!ENDIF
+f2cvvdefs.h: f2cvv
+	f2cvv f2cvvdefs.h
+
+mainf.o: mainf.f
+	$(FC) -c mainf.f
+
+subc.o: subc.c subc_ftoc.o f2cvvdefs.h
+	$(CC) -c subc.c
+
+subc_ftoc.o: f2cvv subc_ftoc.c
+	$(CC) -c subc_ftoc.c
+
+subc_ftoc.c: f2cvv subc.c
+	f2cvv subc.c
+
+mainc.o: mainc.c subf_ctof.o f2cvvdefs.h
+	$(CC) -c mainc.c
+
+subf.o: subf.f
+	$(FC) -c subf.f
+
+subf_ctof.o: f2cvv subf_ctof.c
+	$(CC) -c subf_ctof.c
+
+subf_ctof.c: f2cvv subf.f
+	f2cvv subf.f
+#<
+
+#!ENDIF

*/