d/freebsd-dev
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Remove the old libf2c. libg2c is now serving us well.

Browse Source
This commit is contained in:
David E. O'Brien 1999-04-21 16:43:03 +00:00
parent 565592bd9c
commit f6e41545ea
Notes: svn2git 2020-12-20 02:59:44 +00:00 
svn path=/head/; revision=45922
164 changed files with 0 additions and 9259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
lib/libF77/F77_aloc.c
View File

@ -1,32 +0,0 @@
#include "f2c.h"
#undef abs
#undef min
#undef max
#include "stdio.h"
static integer memfailure = 3;
#ifdef KR_headers
extern char *malloc();
extern void exit_();
char *
F77_aloc(Len, whence) integer Len; char *whence;
#else
#include "stdlib.h"
extern void exit_(integer*);
char *
F77_aloc(integer Len, char *whence)
#endif
{
char *rv;
unsigned int uLen = (unsigned int) Len; /* for K&R C */
if (!(rv = (char*)malloc(uLen))) {
fprintf(stderr, "malloc(%u) failure in %s\n",
uLen, whence);
exit_(&memfailure);
}
return rv;
}

1
lib/libF77/MAIN.c
View File

@ -1 +0,0 @@
MAIN__(){}

23
lib/libF77/Notice
View File

@ -1,23 +0,0 @@
/****************************************************************
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.
****************************************************************/

112
lib/libF77/README
View File

@ -1,112 +0,0 @@
If your compiler does not recognize ANSI C headers,
compile with KR_headers defined: either add -DKR_headers
to the definition of CFLAGS in the makefile, or insert
#define KR_headers
at the top of f2c.h , cabs.c , main.c , and sig_die.c .
Under MS-DOS, compile s_paus.c with -DMSDOS.
If you have a really ancient K&R C compiler that does not understand
void, add -Dvoid=int to the definition of CFLAGS in the makefile.
If you use a C++ compiler, first create a local f2c.h by appending
f2ch.add to the usual f2c.h, e.g., by issuing the command
make f2c.h
which assumes f2c.h is installed in /usr/include .
If your system lacks onexit() and you are not using an ANSI C
compiler, then you should compile main.c, s_paus.c, s_stop.c, and
sig_die.c with NO_ONEXIT defined. See the comments about onexit in
the makefile.
If your system has a double drem() function such that drem(a,b)
is the IEEE remainder function (with double a, b), then you may
wish to compile r_mod.c and d_mod.c with IEEE_drem defined.
On some systems, you may also need to compile with -Ddrem=remainder .
To check for transmission errors, issue the command
make check
This assumes you have the xsum program whose source, xsum.c,
is distributed as part of "all from f2c/src". If you do not
have xsum, you can obtain xsum.c by sending the following E-mail
message to netlib@netlib.bell-labs.com
send xsum.c from f2c/src
The makefile assumes you have installed f2c.h in a standard
place (and does not cause recompilation when f2c.h is changed);
f2c.h comes with "all from f2c" (the source for f2c) and is
available separately ("f2c.h from f2c").
Most of the routines in libF77 are support routines for Fortran
intrinsic functions or for operations that f2c chooses not
to do "in line". There are a few exceptions, summarized below --
functions and subroutines that appear to your program as ordinary
external Fortran routines.
1. CALL ABORT prints a message and causes a core dump.
2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION
error functions (with x REAL and d DOUBLE PRECISION);
DERF must be declared DOUBLE PRECISION in your program.
Both ERF and DERF assume your C library provides the
underlying erf() function (which not all systems do).
3. ERFC(r) and DERFC(d) are the complementary error functions:
ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d)
(except that their results may be more accurate than
explicitly evaluating the above formulae would give).
Again, ERFC and r are REAL, and DERFC and d are DOUBLE
PRECISION (and must be declared as such in your program),
and ERFC and DERFC rely on your system's erfc().
4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER
variable, sets s to the n-th command-line argument (or to
all blanks if there are fewer than n command-line arguments);
CALL GETARG(0,s) sets s to the name of the program (on systems
that support this feature). See IARGC below.
5. CALL GETENV(name, value), where name and value are of type
CHARACTER, sets value to the environment value, $name, of
name (or to blanks if $name has not been set).
6. NARGS = IARGC() sets NARGS to the number of command-line
arguments (an INTEGER value).
7. CALL SIGNAL(n,func), where n is an INTEGER and func is an
EXTERNAL procedure, arranges for func to be invoked when
signal n occurs (on systems where this makes sense).
8. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes
cmd to the system's command processor (on systems where
this can be done).
The makefile does not attempt to compile pow_qq.c, qbitbits.c,
and qbitshft.c, which are meant for use with INTEGER*8. To use
INTEGER*8, you must modify f2c.h to declare longint and ulongint
appropriately; then add pow_qq.o to the POW = line in the makefile,
and add " qbitbits.o qbitshft.o" to the makefile's F90BIT = line.
Following Fortran 90, s_cat.c and s_copy.c allow the target of a
(character string) assignment to be appear on its right-hand, at
the cost of some extra overhead for all run-time concatenations.
If you prefer the extra efficiency that comes with the Fortran 77
requirement that the left-hand side of a character assignment not
be involved in the right-hand side, compile s_cat.c and s_copy.c
with -DNO_OVERWRITE .
If your system lacks a ranlib command, you don't need it.
Either comment out the makefile's ranlib invocation, or install
a harmless "ranlib" command somewhere in your PATH, such as the
one-line shell script
exit 0
or (on some systems)
exec /usr/bin/ar lts $1 >/dev/null
If your compiler complains about the signal calls in main.c, s_paus.c,
and signal_.c, you may need to adjust signal1.h suitably. See the
comments in signal1.h.

53
lib/libF77/Version.c
View File

@ -1,53 +0,0 @@
static char junk[] = "\n@(#)LIBF77 VERSION 19970919\n";
/*
2.00 11 June 1980. File version.c added to library.
2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed
[ d]erf[c ] added
8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c
29 Nov. 1989: s_cmp returns long (for f2c)
30 Nov. 1989: arg types from f2c.h
12 Dec. 1989: s_rnge allows long names
19 Dec. 1989: getenv_ allows unsorted environment
28 Mar. 1990: add exit(0) to end of main()
2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main
17 Oct. 1990: abort() calls changed to sig_die(...,1)
22 Oct. 1990: separate sig_die from main
25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die
31 May 1991: make system_ return status
18 Dec. 1991: change long to ftnlen (for -i2) many places
28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer)
18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c
and m**n in pow_hh.c and pow_ii.c;
catch SIGTRAP in main() for error msg before abort
23 July 1992: switch to ANSI prototypes unless KR_headers is #defined
23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg);
change Cabs to f__cabs.
12 March 1993: various tweaks for C++
2 June 1994: adjust so abnormal terminations invoke f_exit just once
16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons.
19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS
12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines
that sign-extend right shifts when i is the most
negative integer.
26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side
of character assignments to appear on the right-hand
side (unless compiled with -DNO_OVERWRITE).
27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever
possible (for better cache behavior).
30 May 1995: added subroutine exit(rc) integer rc. Version not changed.
29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c.
6 Sept. 1995: fix return type of system_ under -DKR_headers.
19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs.
19 Mar. 1996: s_cat.c: supply missing break after overlap detection.
13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics).
19 June 1996: add casts to unsigned in [lq]bitshft.c.
26 Feb. 1997: adjust functions with a complex output argument
to permit aliasing it with input arguments.
(For now, at least, this is just for possible
benefit of g77.)
4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may
affect systems using gratuitous extra precision).
19 Sept. 1997: [de]time_.c (Unix systems only): change return
type to double.
*/

18
lib/libF77/abort_.c
View File

@ -1,18 +0,0 @@
#include "stdio.h"
#include "f2c.h"
#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);
#ifdef __cplusplus
return 0;
#endif
}

14
lib/libF77/c_abs.c
View File

@ -1,14 +0,0 @@
#include "f2c.h"
#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 ) );
}

17
lib/libF77/c_cos.c
View File

@ -1,17 +0,0 @@
#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"
void c_cos(complex *r, complex *z)
#endif
{
double zr = z->r;
r->r = cos(zr) * cosh(z->i);
r->i = - sin(zr) * sinh(z->i);
}

37
lib/libF77/c_div.c
View File

@ -1,37 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern VOID sig_die();
VOID c_div(c, a, b)
complex *a, *b, *c;
#else
extern void sig_die(char*,int);
void c_div(complex *c, complex *a, complex *b)
#endif
{
double ratio, den;
double abr, abi, cr;
if( (abr = b->r) < 0.)
abr = - abr;
if( (abi = b->i) < 0.)
abi = - abi;
if( abr <= abi )
{
if(abi == 0)
sig_die("complex division by zero", 1);
ratio = (double)b->r / b->i ;
den = b->i * (1 + ratio*ratio);
cr = (a->r*ratio + a->i) / den;
c->i = (a->i*ratio - a->r) / den;
}
else
{
ratio = (double)b->i / b->r ;
den = b->r * (1 + ratio*ratio);
cr = (a->r + a->i*ratio) / den;
c->i = (a->i - a->r*ratio) / den;
}
c->r = cr;
}

19
lib/libF77/c_exp.c
View File

@ -1,19 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern double exp(), cos(), sin();
VOID c_exp(r, z) complex *r, *z;
#else
#undef abs
#include "math.h"
void c_exp(complex *r, complex *z)
#endif
{
double expx;
expx = exp(z->r);
r->r = expx * cos(z->i);
r->i = expx * sin(z->i);
}

17
lib/libF77/c_log.c
View File

@ -1,17 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern double log(), f__cabs(), atan2();
VOID c_log(r, z) complex *r, *z;
#else
#undef abs
#include "math.h"
extern double f__cabs(double, double);
void c_log(complex *r, complex *z)
#endif
{
double zi;
r->i = atan2(zi = z->i, z->r);
r->r = log( f__cabs(z->r, zi) );
}

17
lib/libF77/c_sin.c
View File

@ -1,17 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern double sin(), cos(), sinh(), cosh();
VOID c_sin(r, z) complex *r, *z;
#else
#undef abs
#include "math.h"
void c_sin(complex *r, complex *z)
#endif
{
double zr = z->r;
r->r = sin(zr) * cosh(z->i);
r->i = cos(zr) * sinh(z->i);
}

35
lib/libF77/c_sqrt.c
View File

@ -1,35 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern double sqrt(), f__cabs();
VOID c_sqrt(r, z) complex *r, *z;
#else
#undef abs
#include "math.h"
extern double f__cabs(double, double);
void c_sqrt(complex *r, complex *z)
#endif
{
double mag, t;
double zi = z->i, zr = z->r;
if( (mag = f__cabs(zr, zi)) == 0.)
r->r = r->i = 0.;
else if(zr > 0)
{
r->r = t = sqrt(0.5 * (mag + zr) );
t = zi / t;
r->i = 0.5 * t;
}
else
{
t = sqrt(0.5 * (mag - zr) );
if(zi < 0)
t = -t;
r->i = t;
t = zi / t;
r->r = 0.5 * t;
}
}

27
lib/libF77/cabs.c
View File

@ -1,27 +0,0 @@
#ifdef KR_headers
extern double sqrt();
double f__cabs(real, imag) double real, imag;
#else
#undef abs
#include "math.h"
double f__cabs(double real, double imag)
#endif
{
double temp;
if(real < 0)
real = -real;
if(imag < 0)
imag = -imag;
if(imag > real){
temp = real;
real = imag;
imag = temp;
}
if((real+imag) == real)
return(real);
temp = imag/real;
temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/
return(temp);
}

12
lib/libF77/d_abs.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double d_abs(x) doublereal *x;
#else
double d_abs(doublereal *x)
#endif
{
if(*x >= 0)
return(*x);
return(- *x);
}

13
lib/libF77/d_acos.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double acos();
double d_acos(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_acos(doublereal *x)
#endif
{
return( acos(*x) );
}

13
lib/libF77/d_asin.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double asin();
double d_asin(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_asin(doublereal *x)
#endif
{
return( asin(*x) );
}

13
lib/libF77/d_atan.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double atan();
double d_atan(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_atan(doublereal *x)
#endif
{
return( atan(*x) );
}

13
lib/libF77/d_atn2.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double atan2();
double d_atn2(x,y) doublereal *x, *y;
#else
#undef abs
#include "math.h"
double d_atn2(doublereal *x, doublereal *y)
#endif
{
return( atan2(*x,*y) );
}

12
lib/libF77/d_cnjg.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
VOID
#ifdef KR_headers
d_cnjg(r, z) doublecomplex *r, *z;
#else
d_cnjg(doublecomplex *r, doublecomplex *z)
#endif
{
r->r = z->r;
r->i = - z->i;
}

13
lib/libF77/d_cos.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double cos();
double d_cos(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_cos(doublereal *x)
#endif
{
return( cos(*x) );
}

13
lib/libF77/d_cosh.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double cosh();
double d_cosh(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_cosh(doublereal *x)
#endif
{
return( cosh(*x) );
}

10
lib/libF77/d_dim.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double d_dim(a,b) doublereal *a, *b;
#else
double d_dim(doublereal *a, doublereal *b)
#endif
{
return( *a > *b ? *a - *b : 0);
}

13
lib/libF77/d_exp.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double exp();
double d_exp(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_exp(doublereal *x)
#endif
{
return( exp(*x) );
}

10
lib/libF77/d_imag.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double d_imag(z) doublecomplex *z;
#else
double d_imag(doublecomplex *z)
#endif
{
return(z->i);
}

13
lib/libF77/d_int.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
double d_int(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_int(doublereal *x)
#endif
{
return( (*x>0) ? floor(*x) : -floor(- *x) );
}

15
lib/libF77/d_lg10.c
View File

@ -1,15 +0,0 @@
#include "f2c.h"
#define log10e 0.43429448190325182765
#ifdef KR_headers
double log();
double d_lg10(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_lg10(doublereal *x)
#endif
{
return( log10e * log(*x) );
}

13
lib/libF77/d_log.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double log();
double d_log(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_log(doublereal *x)
#endif
{
return( log(*x) );
}

40
lib/libF77/d_mod.c
View File

@ -1,40 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
#ifdef IEEE_drem
double drem();
#else
double floor();
#endif
double d_mod(x,y) doublereal *x, *y;
#else
#ifdef IEEE_drem
double drem(double, double);
#else
#undef abs
#include "math.h"
#endif
double d_mod(doublereal *x, doublereal *y)
#endif
{
#ifdef IEEE_drem
double xa, ya, z;
if ((ya = *y) < 0.)
ya = -ya;
z = drem(xa = *x, ya);
if (xa > 0) {
if (z < 0)
z += ya;
}
else if (z > 0)
z -= ya;
return z;
#else
double quotient;
if( (quotient = *x / *y) >= 0)
quotient = floor(quotient);
else
quotient = -floor(-quotient);
return(*x - (*y) * quotient );
#endif
}

14
lib/libF77/d_nint.c
View File

@ -1,14 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
double d_nint(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_nint(doublereal *x)
#endif
{
return( (*x)>=0 ?
floor(*x + .5) : -floor(.5 - *x) );
}

10
lib/libF77/d_prod.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double d_prod(x,y) real *x, *y;
#else
double d_prod(real *x, real *y)
#endif
{
return( (*x) * (*y) );
}

12
lib/libF77/d_sign.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double d_sign(a,b) doublereal *a, *b;
#else
double d_sign(doublereal *a, doublereal *b)
#endif
{
double x;
x = (*a >= 0 ? *a : - *a);
return( *b >= 0 ? x : -x);
}

13
lib/libF77/d_sin.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double sin();
double d_sin(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_sin(doublereal *x)
#endif
{
return( sin(*x) );
}

13
lib/libF77/d_sinh.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double sinh();
double d_sinh(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_sinh(doublereal *x)
#endif
{
return( sinh(*x) );
}

13
lib/libF77/d_sqrt.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double sqrt();
double d_sqrt(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_sqrt(doublereal *x)
#endif
{
return( sqrt(*x) );
}

13
lib/libF77/d_tan.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double tan();
double d_tan(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_tan(doublereal *x)
#endif
{
return( tan(*x) );
}

13
lib/libF77/d_tanh.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double tanh();
double d_tanh(x) doublereal *x;
#else
#undef abs
#include "math.h"
double d_tanh(doublereal *x)
#endif
{
return( tanh(*x) );
}

12
lib/libF77/derf_.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double erf();
double derf_(x) doublereal *x;
#else
extern double erf(double);
double derf_(doublereal *x)
#endif
{
return( erf(*x) );
}

14
lib/libF77/derfc_.c
View File

@ -1,14 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern double erfc();
double derfc_(x) doublereal *x;
#else
extern double erfc(double);
double derfc_(doublereal *x)
#endif
{
return( erfc(*x) );
}

21
lib/libF77/ef1asc_.c
View File

@ -1,21 +0,0 @@
/* EFL support routine to copy string b to string a */
#include "f2c.h"
#define M ( (long) (sizeof(long) - 1) )
#define EVEN(x) ( ( (x)+ M) & (~M) )
#ifdef KR_headers
extern VOID s_copy();
ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
#else
extern void s_copy(char*,char*,ftnlen,ftnlen);
int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb)
#endif
{
s_copy( (char *)a, (char *)b, EVEN(*la), *lb );
#ifdef __cplusplus
return 0;
#endif
}

14
lib/libF77/ef1cmc_.c
View File

@ -1,14 +0,0 @@
/* EFL support routine to compare two character strings */
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
#else
extern integer s_cmp(char*,char*,ftnlen,ftnlen);
integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb)
#endif
{
return( s_cmp( (char *)a, (char *)b, *la, *lb) );
}

12
lib/libF77/erf_.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double erf();
double erf_(x) real *x;
#else
extern double erf(double);
double erf_(real *x)
#endif
{
return( erf(*x) );
}

12
lib/libF77/erfc_.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double erfc();
double erfc_(x) real *x;
#else
extern double erfc(double);
double erfc_(real *x)
#endif
{
return( erfc(*x) );
}

37
lib/libF77/exit.c
View File

@ -1,37 +0,0 @@
/* This gives the effect of
subroutine exit(rc)
integer*4 rc
stop
end
* with the added side effect of supplying rc as the program's exit code.
*/
#include "f2c.h"
#undef abs
#undef min
#undef max
#ifndef KR_headers
#include "stdlib.h"
#ifdef __cplusplus
extern "C" {
#endif
extern void f_exit(void);
#endif
void
#ifdef KR_headers
exit_(rc) integer *rc;
#else
exit_(integer *rc)
#endif
{
#ifdef NO_ONEXIT
f_exit();
#endif
exit(*rc);
}
#ifdef __cplusplus
}
#endif

162
lib/libF77/f2ch.add
View File

@ -1,162 +0,0 @@
/* If you are using a C++ compiler, append the following to f2c.h
for compiling libF77 and libI77. */
#ifdef __cplusplus
extern "C" {
extern int abort_(void);
extern double c_abs(complex *);
extern void c_cos(complex *, complex *);
extern void c_div(complex *, complex *, complex *);
extern void c_exp(complex *, complex *);
extern void c_log(complex *, complex *);
extern void c_sin(complex *, complex *);
extern void c_sqrt(complex *, complex *);
extern double d_abs(double *);
extern double d_acos(double *);
extern double d_asin(double *);
extern double d_atan(double *);
extern double d_atn2(double *, double *);
extern void d_cnjg(doublecomplex *, doublecomplex *);
extern double d_cos(double *);
extern double d_cosh(double *);
extern double d_dim(double *, double *);
extern double d_exp(double *);
extern double d_imag(doublecomplex *);
extern double d_int(double *);
extern double d_lg10(double *);
extern double d_log(double *);
extern double d_mod(double *, double *);
extern double d_nint(double *);
extern double d_prod(float *, float *);
extern double d_sign(double *, double *);
extern double d_sin(double *);
extern double d_sinh(double *);
extern double d_sqrt(double *);
extern double d_tan(double *);
extern double d_tanh(double *);
extern double derf_(double *);
extern double derfc_(double *);
extern integer do_fio(ftnint *, char *, ftnlen);
extern integer do_lio(ftnint *, ftnint *, char *, ftnlen);
extern integer do_uio(ftnint *, char *, ftnlen);
extern integer e_rdfe(void);
extern integer e_rdue(void);
extern integer e_rsfe(void);
extern integer e_rsfi(void);
extern integer e_rsle(void);
extern integer e_rsli(void);
extern integer e_rsue(void);
extern integer e_wdfe(void);
extern integer e_wdue(void);
extern integer e_wsfe(void);
extern integer e_wsfi(void);
extern integer e_wsle(void);
extern integer e_wsli(void);
extern integer e_wsue(void);
extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *);
extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *);
extern double erf(double);
extern double erf_(float *);
extern double erfc(double);
extern double erfc_(float *);
extern integer f_back(alist *);
extern integer f_clos(cllist *);
extern integer f_end(alist *);
extern void f_exit(void);
extern integer f_inqu(inlist *);
extern integer f_open(olist *);
extern integer f_rew(alist *);
extern int flush_(void);
extern void getarg_(integer *, char *, ftnlen);
extern void getenv_(char *, char *, ftnlen, ftnlen);
extern short h_abs(short *);
extern short h_dim(short *, short *);
extern short h_dnnt(double *);
extern short h_indx(char *, char *, ftnlen, ftnlen);
extern short h_len(char *, ftnlen);
extern short h_mod(short *, short *);
extern short h_nint(float *);
extern short h_sign(short *, short *);
extern short hl_ge(char *, char *, ftnlen, ftnlen);
extern short hl_gt(char *, char *, ftnlen, ftnlen);
extern short hl_le(char *, char *, ftnlen, ftnlen);
extern short hl_lt(char *, char *, ftnlen, ftnlen);
extern integer i_abs(integer *);
extern integer i_dim(integer *, integer *);
extern integer i_dnnt(double *);
extern integer i_indx(char *, char *, ftnlen, ftnlen);
extern integer i_len(char *, ftnlen);
extern integer i_mod(integer *, integer *);
extern integer i_nint(float *);
extern integer i_sign(integer *, integer *);
extern integer iargc_(void);
extern ftnlen l_ge(char *, char *, ftnlen, ftnlen);
extern ftnlen l_gt(char *, char *, ftnlen, ftnlen);
extern ftnlen l_le(char *, char *, ftnlen, ftnlen);
extern ftnlen l_lt(char *, char *, ftnlen, ftnlen);
extern void pow_ci(complex *, complex *, integer *);
extern double pow_dd(double *, double *);
extern double pow_di(double *, integer *);
extern short pow_hh(short *, shortint *);
extern integer pow_ii(integer *, integer *);
extern double pow_ri(float *, integer *);
extern void pow_zi(doublecomplex *, doublecomplex *, integer *);
extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *);
extern double r_abs(float *);
extern double r_acos(float *);
extern double r_asin(float *);
extern double r_atan(float *);
extern double r_atn2(float *, float *);
extern void r_cnjg(complex *, complex *);
extern double r_cos(float *);
extern double r_cosh(float *);
extern double r_dim(float *, float *);
extern double r_exp(float *);
extern double r_imag(complex *);
extern double r_int(float *);
extern double r_lg10(float *);
extern double r_log(float *);
extern double r_mod(float *, float *);
extern double r_nint(float *);
extern double r_sign(float *, float *);
extern double r_sin(float *);
extern double r_sinh(float *);
extern double r_sqrt(float *);
extern double r_tan(float *);
extern double r_tanh(float *);
extern void s_cat(char *, char **, integer *, integer *, ftnlen);
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
extern void s_copy(char *, char *, ftnlen, ftnlen);
extern int s_paus(char *, ftnlen);
extern integer s_rdfe(cilist *);
extern integer s_rdue(cilist *);
extern integer s_rnge(char *, integer, char *, integer);
extern integer s_rsfe(cilist *);
extern integer s_rsfi(icilist *);
extern integer s_rsle(cilist *);
extern integer s_rsli(icilist *);
extern integer s_rsne(cilist *);
extern integer s_rsni(icilist *);
extern integer s_rsue(cilist *);
extern int s_stop(char *, ftnlen);
extern integer s_wdfe(cilist *);
extern integer s_wdue(cilist *);
extern integer s_wsfe(cilist *);
extern integer s_wsfi(icilist *);
extern integer s_wsle(cilist *);
extern integer s_wsli(icilist *);
extern integer s_wsne(cilist *);
extern integer s_wsni(icilist *);
extern integer s_wsue(cilist *);
extern void sig_die(char *, int);
extern integer signal_(integer *, void (*)(int));
extern integer system_(char *, ftnlen);
extern double z_abs(doublecomplex *);
extern void z_cos(doublecomplex *, doublecomplex *);
extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
extern void z_exp(doublecomplex *, doublecomplex *);
extern void z_log(doublecomplex *, doublecomplex *);
extern void z_sin(doublecomplex *, doublecomplex *);
extern void z_sqrt(doublecomplex *, doublecomplex *);
}
#endif

28
lib/libF77/getarg_.c
View File

@ -1,28 +0,0 @@
#include "f2c.h"
/*
* subroutine getarg(k, c)
* returns the kth unix command argument in fortran character
* variable argument c
*/
#ifdef KR_headers
VOID getarg_(n, s, ls) ftnint *n; register char *s; ftnlen ls;
#else
void getarg_(ftnint *n, register char *s, ftnlen ls)
#endif
{
extern int xargc;
extern char **xargv;
register char *t;
register int i;
if(*n>=0 && *n<xargc)
t = xargv[*n];
else
t = "";
for(i = 0; i<ls && *t!='\0' ; ++i)
*s++ = *t++;
for( ; i<ls ; ++i)
*s++ = ' ';
}

51
lib/libF77/getenv_.c
View File

@ -1,51 +0,0 @@
#include "f2c.h"
/*
* getenv - f77 subroutine to return environment variables
*
* called by:
* call getenv (ENV_NAME, char_var)
* where:
* ENV_NAME is the name of an environment variable
* char_var is a character variable which will receive
* the current value of ENV_NAME, or all blanks
* if ENV_NAME is not defined
*/
#ifdef KR_headers
VOID getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen;
#else
void getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen)
#endif
{
extern char **environ;
register char *ep, *fp, *flast;
register char **env = environ;
flast = fname + flen;
for(fp = fname ; fp < flast ; ++fp)
if(*fp == ' ')
{
flast = fp;
break;
}
while (ep = *env++)
{
for(fp = fname; fp<flast ; )
if(*fp++ != *ep++)
goto endloop;
if(*ep++ == '=') { /* copy right hand side */
while( *ep && --vlen>=0 )
*value++ = *ep++;
goto blank;
}
endloop: ;
}
blank:
while( --vlen >= 0 )
*value++ = ' ';
}

12
lib/libF77/h_abs.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
shortint h_abs(x) shortint *x;
#else
shortint h_abs(shortint *x)
#endif
{
if(*x >= 0)
return(*x);
return(- *x);
}

10
lib/libF77/h_dim.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
shortint h_dim(a,b) shortint *a, *b;
#else
shortint h_dim(shortint *a, shortint *b)
#endif
{
return( *a > *b ? *a - *b : 0);
}

13
lib/libF77/h_dnnt.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
shortint h_dnnt(x) doublereal *x;
#else
#undef abs
#include "math.h"
shortint h_dnnt(doublereal *x)
#endif
{
return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
}

26
lib/libF77/h_indx.c
View File

@ -1,26 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb;
#else
shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
ftnlen i, n;
char *s, *t, *bend;
n = la - lb + 1;
bend = b + lb;
for(i = 0 ; i < n ; ++i)
{
s = a + i;
t = b;
while(t < bend)
if(*s++ != *t++)
goto no;
return((shortint)i+1);
no: ;
}
return(0);
}

10
lib/libF77/h_len.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
shortint h_len(s, n) char *s; ftnlen n;
#else
shortint h_len(char *s, ftnlen n)
#endif
{
return(n);
}

10
lib/libF77/h_mod.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
shortint h_mod(a,b) short *a, *b;
#else
shortint h_mod(short *a, short *b)
#endif
{
return( *a % *b);
}

13
lib/libF77/h_nint.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
shortint h_nint(x) real *x;
#else
#undef abs
#include "math.h"
shortint h_nint(real *x)
#endif
{
return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
}

12
lib/libF77/h_sign.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
shortint h_sign(a,b) shortint *a, *b;
#else
shortint h_sign(shortint *a, shortint *b)
#endif
{
shortint x;
x = (*a >= 0 ? *a : - *a);
return( *b >= 0 ? x : -x);
}

12
lib/libF77/hl_ge.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) >= 0);
}

12
lib/libF77/hl_gt.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) > 0);
}

12
lib/libF77/hl_le.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) <= 0);
}

12
lib/libF77/hl_lt.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) < 0);
}

12
lib/libF77/i_abs.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
integer i_abs(x) integer *x;
#else
integer i_abs(integer *x)
#endif
{
if(*x >= 0)
return(*x);
return(- *x);
}

10
lib/libF77/i_dim.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
integer i_dim(a,b) integer *a, *b;
#else
integer i_dim(integer *a, integer *b)
#endif
{
return( *a > *b ? *a - *b : 0);
}

13
lib/libF77/i_dnnt.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
integer i_dnnt(x) doublereal *x;
#else
#undef abs
#include "math.h"
integer i_dnnt(doublereal *x)
#endif
{
return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
}

26
lib/libF77/i_indx.c
View File

@ -1,26 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb;
#else
integer i_indx(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
ftnlen i, n;
char *s, *t, *bend;
n = la - lb + 1;
bend = b + lb;
for(i = 0 ; i < n ; ++i)
{
s = a + i;
t = b;
while(t < bend)
if(*s++ != *t++)
goto no;
return(i+1);
no: ;
}
return(0);
}

10
lib/libF77/i_len.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
integer i_len(s, n) char *s; ftnlen n;
#else
integer i_len(char *s, ftnlen n)
#endif
{
return(n);
}

10
lib/libF77/i_mod.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
integer i_mod(a,b) integer *a, *b;
#else
integer i_mod(integer *a, integer *b)
#endif
{
return( *a % *b);
}

13
lib/libF77/i_nint.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
integer i_nint(x) real *x;
#else
#undef abs
#include "math.h"
integer i_nint(real *x)
#endif
{
return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
}

12
lib/libF77/i_sign.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
integer i_sign(a,b) integer *a, *b;
#else
integer i_sign(integer *a, integer *b)
#endif
{
integer x;
x = (*a >= 0 ? *a : - *a);
return( *b >= 0 ? x : -x);
}

11
lib/libF77/iargc_.c
View File

@ -1,11 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
ftnint iargc_()
#else
ftnint iargc_(void)
#endif
{
extern int xargc;
return ( xargc - 1 );
}

12
lib/libF77/l_ge.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
logical l_ge(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) >= 0);
}

12
lib/libF77/l_gt.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
logical l_gt(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) > 0);
}

12
lib/libF77/l_le.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
logical l_le(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) <= 0);
}

12
lib/libF77/l_lt.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
extern integer s_cmp();
logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb;
#else
extern integer s_cmp(char *, char *, ftnlen, ftnlen);
logical l_lt(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) < 0);
}

62
lib/libF77/lbitbits.c
View File

@ -1,62 +0,0 @@
#include "f2c.h"
#ifndef LONGBITS
#define LONGBITS 32
#endif
integer
#ifdef KR_headers
lbit_bits(a, b, len) integer a, b, len;
#else
lbit_bits(integer a, integer b, integer len)
#endif
{
/* Assume 2's complement arithmetic */
unsigned long x, y;
x = (unsigned long) a;
y = (unsigned long)-1L;
x >>= b;
y <<= len;
return (integer)(x & ~y);
}
integer
#ifdef KR_headers
lbit_cshift(a, b, len) integer a, b, len;
#else
lbit_cshift(integer a, integer b, integer len)
#endif
{
unsigned long x, y, z;
x = (unsigned long)a;
if (len <= 0) {
if (len == 0)
return 0;
goto full_len;
}
if (len >= LONGBITS) {
full_len:
if (b >= 0) {
b %= LONGBITS;
return (integer)(x << b | x >> LONGBITS -b );
}
b = -b;
b %= LONGBITS;
return (integer)(x << LONGBITS - b | x >> b);
}
y = z = (unsigned long)-1;
y <<= len;
z &= ~y;
y &= x;
x &= z;
if (b >= 0) {
b %= len;
return (integer)(y | z & (x << b | x >> len - b));
}
b = -b;
b %= len;
return (integer)(y | z & (x >> b | x << len - b));
}

11
lib/libF77/lbitshft.c
View File

@ -1,11 +0,0 @@
#include "f2c.h"
integer
#ifdef KR_headers
lbit_shift(a, b) integer a; integer b;
#else
lbit_shift(integer a, integer b)
#endif
{
return b >= 0 ? a << b : (integer)((uinteger)a >> -b);
}

141
lib/libF77/main.c
View File

@ -1,141 +0,0 @@
/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */
#include "stdio.h"
#include "signal1.h"
#ifndef SIGIOT
#ifdef SIGABRT
#define SIGIOT SIGABRT
#endif
#endif
#ifndef KR_headers
#undef VOID
#include "stdlib.h"
#endif
#ifndef VOID
#define VOID void
#endif
#ifdef __cplusplus
extern "C" {
#endif
#ifdef NO__STDC
#define ONEXIT onexit
extern VOID f_exit();
#else
#ifndef KR_headers
extern void f_exit(void);
#ifndef NO_ONEXIT
#define ONEXIT atexit
extern int atexit(void (*)(void));
#endif
#else
#ifndef NO_ONEXIT
#define ONEXIT onexit
extern VOID f_exit();
#endif
#endif
#endif
#ifdef KR_headers
extern VOID f_init(), sig_die();
extern int MAIN__();
#define Int /* int */
#else
extern void f_init(void), sig_die(char*, int);
extern int MAIN__(void);
#define Int int
#endif
static VOID sigfdie(Sigarg)
{
Use_Sigarg;
sig_die("Floating Exception", 1);
}
static VOID sigidie(Sigarg)
{
Use_Sigarg;
sig_die("IOT Trap", 1);
}
#ifdef SIGQUIT
static VOID sigqdie(Sigarg)
{
Use_Sigarg;
sig_die("Quit signal", 1);
}
#endif
static VOID sigindie(Sigarg)
{
Use_Sigarg;
sig_die("Interrupt", 0);
}
static VOID sigtdie(Sigarg)
{
Use_Sigarg;
sig_die("Killed", 0);
}
#ifdef SIGTRAP
static VOID sigtrdie(Sigarg)
{
Use_Sigarg;
sig_die("Trace trap", 1);
}
#endif
int xargc;
char **xargv;
#ifdef __cplusplus
}
#endif
#ifdef KR_headers
main(argc, argv) int argc; char **argv;
#else
main(int argc, char **argv)
#endif
{
xargc = argc;
xargv = argv;
signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
#ifdef SIGIOT
signal1(SIGIOT, sigidie);
#endif
#ifdef SIGTRAP
signal1(SIGTRAP, sigtrdie);
#endif
#ifdef SIGQUIT
if(signal1(SIGQUIT,sigqdie) == SIG_IGN)
signal1(SIGQUIT, SIG_IGN);
#endif
if(signal1(SIGINT, sigindie) == SIG_IGN)
signal1(SIGINT, SIG_IGN);
signal1(SIGTERM,sigtdie);
#ifdef pdp11
ldfps(01200); /* detect overflow as an exception */
#endif
f_init();
#ifndef NO_ONEXIT
ONEXIT(f_exit);
#endif
MAIN__();
#ifdef NO_ONEXIT
f_exit();
#endif
exit(0); /* exit(0) rather than return(0) to bypass Cray bug */
return 0; /* For compilers that complain of missing return values; */
/* others will complain that this is unreachable code. */
}

20
lib/libF77/pow_ci.c
View File

@ -1,20 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
VOID pow_ci(p, a, b) /* p = a**b */
complex *p, *a; integer *b;
#else
extern void pow_zi(doublecomplex*, doublecomplex*, integer*);
void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */
#endif
{
doublecomplex p1, a1;
a1.r = a->r;
a1.i = a->i;
pow_zi(&p1, &a1, b);
p->r = p1.r;
p->i = p1.i;
}

13
lib/libF77/pow_dd.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double pow();
double pow_dd(ap, bp) doublereal *ap, *bp;
#else
#undef abs
#include "math.h"
double pow_dd(doublereal *ap, doublereal *bp)
#endif
{
return(pow(*ap, *bp) );
}

35
lib/libF77/pow_di.c
View File

@ -1,35 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double pow_di(ap, bp) doublereal *ap; integer *bp;
#else
double pow_di(doublereal *ap, integer *bp)
#endif
{
double pow, x;
integer n;
unsigned long u;
pow = 1;
x = *ap;
n = *bp;
if(n != 0)
{
if(n < 0)
{
n = -n;
x = 1/x;
}
for(u = n; ; )
{
if(u & 01)
pow *= x;
if(u >>= 1)
x *= x;
else
break;
}
}
return(pow);
}

33
lib/libF77/pow_hh.c
View File

@ -1,33 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
shortint pow_hh(ap, bp) shortint *ap, *bp;
#else
shortint pow_hh(shortint *ap, shortint *bp)
#endif
{
shortint pow, x, n;
unsigned u;
x = *ap;
n = *bp;
if (n <= 0) {
if (n == 0 || x == 1)
return 1;
if (x != -1)
return x == 0 ? 1/x : 0;
n = -n;
}
u = n;
for(pow = 1; ; )
{
if(u & 01)
pow *= x;
if(u >>= 1)
x *= x;
else
break;
}
return(pow);
}

33
lib/libF77/pow_ii.c
View File

@ -1,33 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
integer pow_ii(ap, bp) integer *ap, *bp;
#else
integer pow_ii(integer *ap, integer *bp)
#endif
{
integer pow, x, n;
unsigned long u;
x = *ap;
n = *bp;
if (n <= 0) {
if (n == 0 || x == 1)
return 1;
if (x != -1)
return x == 0 ? 1/x : 0;
n = -n;
}
u = n;
for(pow = 1; ; )
{
if(u & 01)
pow *= x;
if(u >>= 1)
x *= x;
else
break;
}
return(pow);
}

33
lib/libF77/pow_qq.c
View File

@ -1,33 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
longint pow_qq(ap, bp) longint *ap, *bp;
#else
longint pow_qq(longint *ap, longint *bp)
#endif
{
longint pow, x, n;
unsigned long long u; /* system-dependent */
x = *ap;
n = *bp;
if (n <= 0) {
if (n == 0 || x == 1)
return 1;
if (x != -1)
return x == 0 ? 1/x : 0;
n = -n;
}
u = n;
for(pow = 1; ; )
{
if(u & 01)
pow *= x;
if(u >>= 1)
x *= x;
else
break;
}
return(pow);
}

35
lib/libF77/pow_ri.c
View File

@ -1,35 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double pow_ri(ap, bp) real *ap; integer *bp;
#else
double pow_ri(real *ap, integer *bp)
#endif
{
double pow, x;
integer n;
unsigned long u;
pow = 1;
x = *ap;
n = *bp;
if(n != 0)
{
if(n < 0)
{
n = -n;
x = 1/x;
}
for(u = n; ; )
{
if(u & 01)
pow *= x;
if(u >>= 1)
x *= x;
else
break;
}
}
return(pow);
}

54
lib/libF77/pow_zi.c
View File

@ -1,54 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
VOID pow_zi(p, a, b) /* p = a**b */
doublecomplex *p, *a; integer *b;
#else
extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*);
void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */
#endif
{
integer n;
unsigned long u;
double t;
doublecomplex q, x;
static doublecomplex one = {1.0, 0.0};
n = *b;
q.r = 1;
q.i = 0;
if(n == 0)
goto done;
if(n < 0)
{
n = -n;
z_div(&x, &one, a);
}
else
{
x.r = a->r;
x.i = a->i;
}
for(u = n; ; )
{
if(u & 01)
{
t = q.r * x.r - q.i * x.i;
q.i = q.r * x.i + q.i * x.r;
q.r = t;
}
if(u >>= 1)
{
t = x.r * x.r - x.i * x.i;
x.i = 2 * x.r * x.i;
x.r = t;
}
else
break;
}
done:
p->i = q.i;
p->r = q.r;
}

23
lib/libF77/pow_zz.c
View File

@ -1,23 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double log(), exp(), cos(), sin(), atan2(), f__cabs();
VOID pow_zz(r,a,b) doublecomplex *r, *a, *b;
#else
#undef abs
#include "math.h"
extern double f__cabs(double,double);
void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b)
#endif
{
double logr, logi, x, y;
logr = log( f__cabs(a->r, a->i) );
logi = atan2(a->i, a->r);
x = exp( logr * b->r - logi * b->i );
y = logr * b->i + logi * b->r;
r->r = x * cos(y);
r->i = x * sin(y);
}

12
lib/libF77/r_abs.c
View File

@ -1,12 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double r_abs(x) real *x;
#else
double r_abs(real *x)
#endif
{
if(*x >= 0)
return(*x);
return(- *x);
}

13
lib/libF77/r_acos.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double acos();
double r_acos(x) real *x;
#else
#undef abs
#include "math.h"
double r_acos(real *x)
#endif
{
return( acos(*x) );
}

13
lib/libF77/r_asin.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double asin();
double r_asin(x) real *x;
#else
#undef abs
#include "math.h"
double r_asin(real *x)
#endif
{
return( asin(*x) );
}

13
lib/libF77/r_atan.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double atan();
double r_atan(x) real *x;
#else
#undef abs
#include "math.h"
double r_atan(real *x)
#endif
{
return( atan(*x) );
}

13
lib/libF77/r_atn2.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double atan2();
double r_atn2(x,y) real *x, *y;
#else
#undef abs
#include "math.h"
double r_atn2(real *x, real *y)
#endif
{
return( atan2(*x,*y) );
}

11
lib/libF77/r_cnjg.c
View File

@ -1,11 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
VOID r_cnjg(r, z) complex *r, *z;
#else
VOID r_cnjg(complex *r, complex *z)
#endif
{
r->r = z->r;
r->i = - z->i;
}

13
lib/libF77/r_cos.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double cos();
double r_cos(x) real *x;
#else
#undef abs
#include "math.h"
double r_cos(real *x)
#endif
{
return( cos(*x) );
}

13
lib/libF77/r_cosh.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double cosh();
double r_cosh(x) real *x;
#else
#undef abs
#include "math.h"
double r_cosh(real *x)
#endif
{
return( cosh(*x) );
}

10
lib/libF77/r_dim.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double r_dim(a,b) real *a, *b;
#else
double r_dim(real *a, real *b)
#endif
{
return( *a > *b ? *a - *b : 0);
}

13
lib/libF77/r_exp.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double exp();
double r_exp(x) real *x;
#else
#undef abs
#include "math.h"
double r_exp(real *x)
#endif
{
return( exp(*x) );
}

10
lib/libF77/r_imag.c
View File

@ -1,10 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double r_imag(z) complex *z;
#else
double r_imag(complex *z)
#endif
{
return(z->i);
}

13
lib/libF77/r_int.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
double r_int(x) real *x;
#else
#undef abs
#include "math.h"
double r_int(real *x)
#endif
{
return( (*x>0) ? floor(*x) : -floor(- *x) );
}

15
lib/libF77/r_lg10.c
View File

@ -1,15 +0,0 @@
#include "f2c.h"
#define log10e 0.43429448190325182765
#ifdef KR_headers
double log();
double r_lg10(x) real *x;
#else
#undef abs
#include "math.h"
double r_lg10(real *x)
#endif
{
return( log10e * log(*x) );
}

13
lib/libF77/r_log.c
View File

@ -1,13 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double log();
double r_log(x) real *x;
#else
#undef abs
#include "math.h"
double r_log(real *x)
#endif
{
return( log(*x) );
}

40
lib/libF77/r_mod.c
View File

@ -1,40 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
#ifdef IEEE_drem
double drem();
#else
double floor();
#endif
double r_mod(x,y) real *x, *y;
#else
#ifdef IEEE_drem
double drem(double, double);
#else
#undef abs
#include "math.h"
#endif
double r_mod(real *x, real *y)
#endif
{
#ifdef IEEE_drem
double xa, ya, z;
if ((ya = *y) < 0.)
ya = -ya;
z = drem(xa = *x, ya);
if (xa > 0) {
if (z < 0)
z += ya;
}
else if (z > 0)
z -= ya;
return z;
#else
double quotient;
if( (quotient = (double)*x / *y) >= 0)
quotient = floor(quotient);
else
quotient = -floor(-quotient);
return(*x - (*y) * quotient );
#endif
}

14
lib/libF77/r_nint.c
View File

@ -1,14 +0,0 @@
#include "f2c.h"
#ifdef KR_headers
double floor();
double r_nint(x) real *x;
#else
#undef abs
#include "math.h"
double r_nint(real *x)
#endif
{
return( (*x)>=0 ?
floor(*x + .5) : -floor(.5 - *x) );
}

Some files were not shown because too many files have changed in this diff Show More