Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Added libf2c for simple access from c to fortran solvers
git-svn-id: https://openmodelica.org/svn/OpenModelica/trunk@1833 f25d12d1-65f4-0310-ae8a-bbce733d8d8e
- Loading branch information
x02lucpo
committed
Jun 27, 2005
1 parent
68ada34
commit 0076e30
Showing
181 changed files
with
13,206 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,23 @@ | ||
/**************************************************************** | ||
Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. | ||
|
||
Permission to use, copy, modify, and distribute this software | ||
and its documentation for any purpose and without fee is hereby | ||
granted, provided that the above copyright notice appear in all | ||
copies and that both that the copyright notice and this | ||
permission notice and warranty disclaimer appear in supporting | ||
documentation, and that the names of AT&T, Bell Laboratories, | ||
Lucent or Bellcore or any of their entities not be used in | ||
advertising or publicity pertaining to distribution of the | ||
software without specific, written prior permission. | ||
|
||
AT&T, Lucent and Bellcore disclaim all warranties with regard to | ||
this software, including all implied warranties of | ||
merchantability and fitness. In no event shall AT&T, Lucent or | ||
Bellcore be liable for any special, indirect or consequential | ||
damages or any damages whatsoever resulting from loss of use, | ||
data or profits, whether in an action of contract, negligence or | ||
other tortious action, arising out of or in connection with the | ||
use or performance of this software. | ||
****************************************************************/ | ||
|
Large diffs are not rendered by default.
Oops, something went wrong.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,22 @@ | ||
#include "stdio.h" | ||
#include "f2c.h" | ||
#ifdef __cplusplus | ||
extern "C" { | ||
#endif | ||
|
||
#ifdef KR_headers | ||
extern VOID sig_die(); | ||
|
||
int abort_() | ||
#else | ||
extern void sig_die(char*,int); | ||
|
||
int abort_(void) | ||
#endif | ||
{ | ||
sig_die("Fortran abort routine called", 1); | ||
return 0; /* not reached */ | ||
} | ||
#ifdef __cplusplus | ||
} | ||
#endif |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,225 @@ | ||
/**************************************************************** | ||
Copyright (C) 1997, 1998, 2000 Lucent Technologies | ||
All Rights Reserved | ||
Permission to use, copy, modify, and distribute this software and | ||
its documentation for any purpose and without fee is hereby | ||
granted, provided that the above copyright notice appear in all | ||
copies and that both that the copyright notice and this | ||
permission notice and warranty disclaimer appear in supporting | ||
documentation, and that the name of Lucent or any of its entities | ||
not be used in advertising or publicity pertaining to | ||
distribution of the software without specific, written prior | ||
permission. | ||
LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, | ||
INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. | ||
IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY | ||
SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES | ||
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER | ||
IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | ||
ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF | ||
THIS SOFTWARE. | ||
****************************************************************/ | ||
|
||
/* Try to deduce arith.h from arithmetic properties. */ | ||
|
||
#include <stdio.h> | ||
#include <math.h> | ||
#include <errno.h> | ||
|
||
#ifdef NO_FPINIT | ||
#define fpinit_ASL() | ||
#else | ||
#ifndef KR_headers | ||
extern | ||
#ifdef __cplusplus | ||
"C" | ||
#endif | ||
void fpinit_ASL(void); | ||
#endif /*KR_headers*/ | ||
#endif /*NO_FPINIT*/ | ||
|
||
static int dalign; | ||
typedef struct | ||
Akind { | ||
char *name; | ||
int kind; | ||
} Akind; | ||
|
||
static Akind | ||
IEEE_8087 = { "IEEE_8087", 1 }, | ||
IEEE_MC68k = { "IEEE_MC68k", 2 }, | ||
IBM = { "IBM", 3 }, | ||
VAX = { "VAX", 4 }, | ||
CRAY = { "CRAY", 5}; | ||
|
||
static double t_nan; | ||
|
||
static Akind * | ||
Lcheck() | ||
{ | ||
union { | ||
double d; | ||
long L[2]; | ||
} u; | ||
struct { | ||
double d; | ||
long L; | ||
} x[2]; | ||
|
||
if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) | ||
dalign = 1; | ||
u.L[0] = u.L[1] = 0; | ||
u.d = 1e13; | ||
if (u.L[0] == 1117925532 && u.L[1] == -448790528) | ||
return &IEEE_MC68k; | ||
if (u.L[1] == 1117925532 && u.L[0] == -448790528) | ||
return &IEEE_8087; | ||
if (u.L[0] == -2065213935 && u.L[1] == 10752) | ||
return &VAX; | ||
if (u.L[0] == 1267827943 && u.L[1] == 704643072) | ||
return &IBM; | ||
return 0; | ||
} | ||
|
||
static Akind * | ||
icheck() | ||
{ | ||
union { | ||
double d; | ||
int L[2]; | ||
} u; | ||
struct { | ||
double d; | ||
int L; | ||
} x[2]; | ||
|
||
if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) | ||
dalign = 1; | ||
u.L[0] = u.L[1] = 0; | ||
u.d = 1e13; | ||
if (u.L[0] == 1117925532 && u.L[1] == -448790528) | ||
return &IEEE_MC68k; | ||
if (u.L[1] == 1117925532 && u.L[0] == -448790528) | ||
return &IEEE_8087; | ||
if (u.L[0] == -2065213935 && u.L[1] == 10752) | ||
return &VAX; | ||
if (u.L[0] == 1267827943 && u.L[1] == 704643072) | ||
return &IBM; | ||
return 0; | ||
} | ||
|
||
char *emptyfmt = ""; /* avoid possible warning message with printf("") */ | ||
|
||
static Akind * | ||
ccheck() | ||
{ | ||
union { | ||
double d; | ||
long L; | ||
} u; | ||
long Cray1; | ||
|
||
/* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ | ||
Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; | ||
if (printf(emptyfmt, Cray1) >= 0) | ||
Cray1 = 1000000*Cray1 + 693716; | ||
if (printf(emptyfmt, Cray1) >= 0) | ||
Cray1 = 1000000*Cray1 + 115456; | ||
u.d = 1e13; | ||
if (u.L == Cray1) | ||
return &CRAY; | ||
return 0; | ||
} | ||
|
||
static int | ||
fzcheck() | ||
{ | ||
double a, b; | ||
int i; | ||
|
||
a = 1.; | ||
b = .1; | ||
for(i = 155;; b *= b, i >>= 1) { | ||
if (i & 1) { | ||
a *= b; | ||
if (i == 1) | ||
break; | ||
} | ||
} | ||
b = a * a; | ||
return b == 0.; | ||
} | ||
|
||
static int | ||
need_nancheck() | ||
{ | ||
double t; | ||
|
||
errno = 0; | ||
t = log(t_nan); | ||
if (errno == 0) | ||
return 1; | ||
errno = 0; | ||
t = sqrt(t_nan); | ||
return errno == 0; | ||
} | ||
|
||
main() | ||
{ | ||
FILE *f; | ||
Akind *a = 0; | ||
int Ldef = 0; | ||
|
||
fpinit_ASL(); | ||
#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ | ||
f = fopen("arith.h", "w"); | ||
if (!f) { | ||
printf("Cannot open arith.h\n"); | ||
return 1; | ||
} | ||
#else | ||
f = stdout; | ||
#endif | ||
|
||
if (sizeof(double) == 2*sizeof(long)) | ||
a = Lcheck(); | ||
else if (sizeof(double) == 2*sizeof(int)) { | ||
Ldef = 1; | ||
a = icheck(); | ||
} | ||
else if (sizeof(double) == sizeof(long)) | ||
a = ccheck(); | ||
if (a) { | ||
fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", | ||
a->name, a->kind); | ||
if (Ldef) | ||
fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); | ||
if (dalign) | ||
fprintf(f, "#define Double_Align\n"); | ||
if (sizeof(char*) == 8) | ||
fprintf(f, "#define X64_bit_pointers\n"); | ||
#ifndef NO_LONG_LONG | ||
if (sizeof(long long) < 8) | ||
#endif | ||
fprintf(f, "#define NO_LONG_LONG\n"); | ||
if (a->kind <= 2) { | ||
if (fzcheck()) | ||
fprintf(f, "#define Sudden_Underflow\n"); | ||
t_nan = -a->kind; | ||
if (need_nancheck()) | ||
fprintf(f, "#define NANCHECK\n"); | ||
} | ||
return 0; | ||
} | ||
fprintf(f, "/* Unknown arithmetic */\n"); | ||
return 1; | ||
} | ||
|
||
#ifdef __sun | ||
#ifdef __i386 | ||
/* kludge for Intel Solaris */ | ||
void fpsetprec(int x) { } | ||
#endif | ||
#endif |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,76 @@ | ||
#include "f2c.h" | ||
#include "fio.h" | ||
#ifdef __cplusplus | ||
extern "C" { | ||
#endif | ||
#ifdef KR_headers | ||
integer f_back(a) alist *a; | ||
#else | ||
integer f_back(alist *a) | ||
#endif | ||
{ unit *b; | ||
OFF_T v, w, x, y, z; | ||
uiolen n; | ||
FILE *f; | ||
|
||
f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ | ||
if(a->aunit >= MXUNIT || a->aunit < 0) | ||
err(a->aerr,101,"backspace") | ||
if(b->useek==0) err(a->aerr,106,"backspace") | ||
if(b->ufd == NULL) { | ||
fk_open(1, 1, a->aunit); | ||
return(0); | ||
} | ||
if(b->uend==1) | ||
{ b->uend=0; | ||
return(0); | ||
} | ||
if(b->uwrt) { | ||
t_runc(a); | ||
if (f__nowreading(b)) | ||
err(a->aerr,errno,"backspace") | ||
} | ||
f = b->ufd; /* may have changed in t_runc() */ | ||
if(b->url>0) | ||
{ | ||
x=FTELL(f); | ||
y = x % b->url; | ||
if(y == 0) x--; | ||
x /= b->url; | ||
x *= b->url; | ||
(void) FSEEK(f,x,SEEK_SET); | ||
return(0); | ||
} | ||
|
||
if(b->ufmt==0) | ||
{ FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); | ||
fread((char *)&n,sizeof(uiolen),1,f); | ||
FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); | ||
return(0); | ||
} | ||
w = x = FTELL(f); | ||
z = 0; | ||
loop: | ||
while(x) { | ||
x -= x < 64 ? x : 64; | ||
FSEEK(f,x,SEEK_SET); | ||
for(y = x; y < w; y++) { | ||
if (getc(f) != '\n') | ||
continue; | ||
v = FTELL(f); | ||
if (v == w) { | ||
if (z) | ||
goto break2; | ||
goto loop; | ||
} | ||
z = v; | ||
} | ||
err(a->aerr,(EOF),"backspace") | ||
} | ||
break2: | ||
FSEEK(f, z, SEEK_SET); | ||
return 0; | ||
} | ||
#ifdef __cplusplus | ||
} | ||
#endif |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,20 @@ | ||
#include "f2c.h" | ||
#ifdef __cplusplus | ||
extern "C" { | ||
#endif | ||
|
||
#ifdef KR_headers | ||
extern double f__cabs(); | ||
|
||
double c_abs(z) complex *z; | ||
#else | ||
extern double f__cabs(double, double); | ||
|
||
double c_abs(complex *z) | ||
#endif | ||
{ | ||
return( f__cabs( z->r, z->i ) ); | ||
} | ||
#ifdef __cplusplus | ||
} | ||
#endif |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,23 @@ | ||
#include "f2c.h" | ||
|
||
#ifdef KR_headers | ||
extern double sin(), cos(), sinh(), cosh(); | ||
|
||
VOID c_cos(r, z) complex *r, *z; | ||
#else | ||
#undef abs | ||
#include "math.h" | ||
#ifdef __cplusplus | ||
extern "C" { | ||
#endif | ||
|
||
void c_cos(complex *r, complex *z) | ||
#endif | ||
{ | ||
double zi = z->i, zr = z->r; | ||
r->r = cos(zr) * cosh(zi); | ||
r->i = - sin(zr) * sinh(zi); | ||
} | ||
#ifdef __cplusplus | ||
} | ||
#endif |
Oops, something went wrong.