mirror of
https://github.com/freebsd/freebsd-src.git
synced 2024-11-27 00:33:30 +00:00
Library for f2c (part 2 of 2)
Obtained from: netlib.att.com
This commit is contained in:
parent
876f9d8347
commit
09c656ca68
Notes:
svn2git
2020-12-20 02:59:44 +00:00
svn path=/cvs2svn/branches/ATT/; revision=3902
23
lib/libF77/Notice
Normal file
23
lib/libF77/Notice
Normal file
@ -0,0 +1,23 @@
|
||||
/****************************************************************
|
||||
Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories 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 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 and Bellcore disclaim all warranties with regard to this
|
||||
software, including all implied warranties of merchantability
|
||||
and fitness. In no event shall AT&T 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.
|
||||
****************************************************************/
|
||||
|
94
lib/libF77/README
Normal file
94
lib/libF77/README
Normal file
@ -0,0 +1,94 @@
|
||||
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@research.att.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, which is meant
|
||||
for use with INTEGER*8. To use it, you must modify f2c.h to
|
||||
declare longint appropriately; then add pow_qq.o to the POW =
|
||||
line in the makefile.
|
||||
|
||||
If you wish to allow the target of a (character string) concatenation
|
||||
to be appear on its right-hand (at the cost of extra overhead for
|
||||
all run-time concatenations), change "s_cat.o" to "s_catow.o" in
|
||||
the makefile. Note that the Fortran 77 Standard explicitly forbids
|
||||
the target of a concatenation from appearing on its right-hand side.
|
30
lib/libF77/Version.c
Normal file
30
lib/libF77/Version.c
Normal file
@ -0,0 +1,30 @@
|
||||
static char junk[] = "\n@(#)LIBF77 VERSION 2.01 19 Sept. 1994\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
|
||||
*/
|
18
lib/libF77/abort_.c
Normal file
18
lib/libF77/abort_.c
Normal file
@ -0,0 +1,18 @@
|
||||
#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
Normal file
14
lib/libF77/c_abs.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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 ) );
|
||||
}
|
16
lib/libF77/c_cos.c
Normal file
16
lib/libF77/c_cos.c
Normal file
@ -0,0 +1,16 @@
|
||||
#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
|
||||
{
|
||||
r->r = cos(z->r) * cosh(z->i);
|
||||
r->i = - sin(z->r) * sinh(z->i);
|
||||
}
|
36
lib/libF77/c_div.c
Normal file
36
lib/libF77/c_div.c
Normal file
@ -0,0 +1,36 @@
|
||||
#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;
|
||||
|
||||
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);
|
||||
c->r = (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);
|
||||
c->r = (a->r + a->i*ratio) / den;
|
||||
c->i = (a->i - a->r*ratio) / den;
|
||||
}
|
||||
}
|
19
lib/libF77/c_exp.c
Normal file
19
lib/libF77/c_exp.c
Normal file
@ -0,0 +1,19 @@
|
||||
#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);
|
||||
}
|
16
lib/libF77/c_log.c
Normal file
16
lib/libF77/c_log.c
Normal file
@ -0,0 +1,16 @@
|
||||
#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
|
||||
{
|
||||
r->i = atan2(z->i, z->r);
|
||||
r->r = log( f__cabs(z->r, z->i) );
|
||||
}
|
16
lib/libF77/c_sin.c
Normal file
16
lib/libF77/c_sin.c
Normal file
@ -0,0 +1,16 @@
|
||||
#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
|
||||
{
|
||||
r->r = sin(z->r) * cosh(z->i);
|
||||
r->i = cos(z->r) * sinh(z->i);
|
||||
}
|
34
lib/libF77/c_sqrt.c
Normal file
34
lib/libF77/c_sqrt.c
Normal file
@ -0,0 +1,34 @@
|
||||
#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;
|
||||
|
||||
if( (mag = f__cabs(z->r, z->i)) == 0.)
|
||||
r->r = r->i = 0.;
|
||||
else if(z->r > 0)
|
||||
{
|
||||
r->r = t = sqrt(0.5 * (mag + z->r) );
|
||||
t = z->i / t;
|
||||
r->i = 0.5 * t;
|
||||
}
|
||||
else
|
||||
{
|
||||
t = sqrt(0.5 * (mag - z->r) );
|
||||
if(z->i < 0)
|
||||
t = -t;
|
||||
r->i = t;
|
||||
t = z->i / t;
|
||||
r->r = 0.5 * t;
|
||||
}
|
||||
}
|
27
lib/libF77/cabs.c
Normal file
27
lib/libF77/cabs.c
Normal file
@ -0,0 +1,27 @@
|
||||
#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
Normal file
12
lib/libF77/d_abs.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
13
lib/libF77/d_acos.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_asin.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_atan.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_atn2.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
12
lib/libF77/d_cnjg.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
13
lib/libF77/d_cos.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_cosh.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
10
lib/libF77/d_dim.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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
Normal file
13
lib/libF77/d_exp.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
10
lib/libF77/d_imag.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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
Normal file
13
lib/libF77/d_int.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
15
lib/libF77/d_lg10.c
Normal file
@ -0,0 +1,15 @@
|
||||
#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
Normal file
13
lib/libF77/d_log.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
40
lib/libF77/d_mod.c
Normal file
@ -0,0 +1,40 @@
|
||||
#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
Normal file
14
lib/libF77/d_nint.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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
Normal file
10
lib/libF77/d_prod.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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
Normal file
12
lib/libF77/d_sign.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
13
lib/libF77/d_sin.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_sinh.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_sqrt.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_tan.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/d_tanh.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
12
lib/libF77/derf_.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
14
lib/libF77/derfc_.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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
Normal file
21
lib/libF77/ef1asc_.c
Normal file
@ -0,0 +1,21 @@
|
||||
/* 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
Normal file
14
lib/libF77/ef1cmc_.c
Normal file
@ -0,0 +1,14 @@
|
||||
/* 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
Normal file
12
lib/libF77/erf_.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/erfc_.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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) );
|
||||
}
|
162
lib/libF77/f2ch.add
Normal file
162
lib/libF77/f2ch.add
Normal file
@ -0,0 +1,162 @@
|
||||
/* 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 int 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
Normal file
28
lib/libF77/getarg_.c
Normal file
@ -0,0 +1,28 @@
|
||||
#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
Normal file
51
lib/libF77/getenv_.c
Normal file
@ -0,0 +1,51 @@
|
||||
#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
Normal file
12
lib/libF77/h_abs.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
10
lib/libF77/h_dim.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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);
|
||||
}
|
14
lib/libF77/h_dnnt.c
Normal file
14
lib/libF77/h_dnnt.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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( (*x)>=0 ?
|
||||
floor(*x + .5) : -floor(.5 - *x) );
|
||||
}
|
26
lib/libF77/h_indx.c
Normal file
26
lib/libF77/h_indx.c
Normal file
@ -0,0 +1,26 @@
|
||||
#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
Normal file
10
lib/libF77/h_len.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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
Normal file
10
lib/libF77/h_mod.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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);
|
||||
}
|
14
lib/libF77/h_nint.c
Normal file
14
lib/libF77/h_nint.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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( (*x)>=0 ?
|
||||
floor(*x + .5) : -floor(.5 - *x) );
|
||||
}
|
12
lib/libF77/h_sign.c
Normal file
12
lib/libF77/h_sign.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/hl_ge.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/hl_gt.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/hl_le.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/hl_lt.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/i_abs.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
10
lib/libF77/i_dim.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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);
|
||||
}
|
14
lib/libF77/i_dnnt.c
Normal file
14
lib/libF77/i_dnnt.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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( (*x)>=0 ?
|
||||
floor(*x + .5) : -floor(.5 - *x) );
|
||||
}
|
26
lib/libF77/i_indx.c
Normal file
26
lib/libF77/i_indx.c
Normal file
@ -0,0 +1,26 @@
|
||||
#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
Normal file
10
lib/libF77/i_len.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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
Normal file
10
lib/libF77/i_mod.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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);
|
||||
}
|
14
lib/libF77/i_nint.c
Normal file
14
lib/libF77/i_nint.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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( (*x)>=0 ?
|
||||
floor(*x + .5) : -floor(.5 - *x) );
|
||||
}
|
12
lib/libF77/i_sign.c
Normal file
12
lib/libF77/i_sign.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
11
lib/libF77/iargc_.c
Normal file
@ -0,0 +1,11 @@
|
||||
#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
Normal file
12
lib/libF77/l_ge.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/l_gt.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/l_le.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
12
lib/libF77/l_lt.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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);
|
||||
}
|
119
lib/libF77/libF77.xsum
Normal file
119
lib/libF77/libF77.xsum
Normal file
@ -0,0 +1,119 @@
|
||||
Notice 1211689a 1195
|
||||
README 1c4c3814 4053
|
||||
Version.c 10d0f4c6 1447
|
||||
abort_.c eaf90dc0 239
|
||||
c_abs.c ecce7a47 205
|
||||
c_cos.c f2338a46 260
|
||||
c_div.c f780c50e 665
|
||||
c_exp.c e1b005d5 270
|
||||
c_log.c 4050533 292
|
||||
c_sin.c f19855c9 258
|
||||
c_sqrt.c 4e1ad71 505
|
||||
cabs.c abac46c 427
|
||||
d_abs.c ed70186c 151
|
||||
d_acos.c e5d8cdee 178
|
||||
d_asin.c f1c92f52 178
|
||||
d_atan.c fe8cfd3f 178
|
||||
d_atn2.c fa5f66a9 204
|
||||
d_cnjg.c 16aaf72f 165
|
||||
d_cos.c f37be16 174
|
||||
d_cosh.c a2f7dcf 178
|
||||
d_dim.c 1dfe4b39 165
|
||||
d_exp.c fb0efb6d 174
|
||||
d_imag.c ff9da248 134
|
||||
d_int.c e10c5fc2 202
|
||||
d_lg10.c 1381342c 224
|
||||
d_log.c ec2a8447 174
|
||||
d_mod.c e30684f1 621
|
||||
d_nint.c ffa7895c 214
|
||||
d_prod.c e3b5d46a 140
|
||||
d_sign.c 1782063b 199
|
||||
d_sin.c ef24638e 174
|
||||
d_sinh.c e0ec938a 178
|
||||
d_sqrt.c 1ff988eb 178
|
||||
d_tan.c ffc9a88e 174
|
||||
d_tanh.c e5e0cbbd 178
|
||||
derf_.c fdf1917c 172
|
||||
derfc_.c 4cb5ea3 186
|
||||
ef1asc_.c f14b3469 453
|
||||
ef1cmc_.c 1e0b86e3 360
|
||||
erf_.c 7a407d 158
|
||||
erfc_.c fb488e22 163
|
||||
f2ch.add fed3bb7b 6056
|
||||
getarg_.c edcf61f8 495
|
||||
getenv_.c eaafcc11 975
|
||||
h_abs.c 8383aa6 151
|
||||
h_dim.c 9f9a693 163
|
||||
h_dnnt.c d754cc8 218
|
||||
h_indx.c 145ff2e8 375
|
||||
h_len.c e85aa13f 138
|
||||
h_mod.c feacad2a 140
|
||||
h_nint.c eb54a855 206
|
||||
h_sign.c e7d69d03 199
|
||||
hl_ge.c 26bca46 279
|
||||
hl_gt.c f5426c57 278
|
||||
hl_le.c ff67a970 279
|
||||
hl_lt.c f8842102 278
|
||||
i_abs.c f6c3045e 147
|
||||
i_dim.c ae23de2 158
|
||||
i_dnnt.c e0c7e5e4 216
|
||||
i_indx.c 19177d0c 363
|
||||
i_len.c e32e1f92 136
|
||||
i_mod.c 8bb577c 144
|
||||
i_nint.c e0a366e8 204
|
||||
i_sign.c 1f26e421 193
|
||||
iargc_.c 324b252 129
|
||||
l_ge.c 5b7cb55 267
|
||||
l_gt.c ad1b388 266
|
||||
l_le.c f5407149 267
|
||||
l_lt.c f81a93f8 266
|
||||
main.c ec7fc5ad 2012
|
||||
makefile 1f2ebd87 3036
|
||||
pow_ci.c f593b0b9 345
|
||||
pow_dd.c e451857d 209
|
||||
pow_di.c f5c04524 360
|
||||
pow_hh.c feb3b910 401
|
||||
pow_ii.c fe444c9b 395
|
||||
pow_qq.c fdf1dc33 395
|
||||
pow_ri.c ea06b62d 348
|
||||
pow_zi.c f21e1934 694
|
||||
pow_zz.c f0e5f141 482
|
||||
r_abs.c 1a4e3da 139
|
||||
r_acos.c ca67f96 166
|
||||
r_asin.c 188a2306 166
|
||||
r_atan.c fadda9d5 166
|
||||
r_atn2.c e97a5392 186
|
||||
r_cnjg.c f1c1fd80 151
|
||||
r_cos.c f19d771e 162
|
||||
r_cosh.c e20187a0 166
|
||||
r_dim.c ef5e869 147
|
||||
r_exp.c 18979beb 162
|
||||
r_imag.c e45086cf 122
|
||||
r_int.c f2c2f39c 190
|
||||
r_lg10.c 1279226d 212
|
||||
r_log.c 2682a0d 162
|
||||
r_mod.c f28ec59a 611
|
||||
r_nint.c 69d11bb 202
|
||||
r_sign.c eddb76f9 181
|
||||
r_sin.c 10007227 162
|
||||
r_sinh.c f21a38b8 166
|
||||
r_sqrt.c f24b8aa4 166
|
||||
r_tan.c e60b7778 162
|
||||
r_tanh.c f22ec5c 166
|
||||
s_cat.c e53641 408
|
||||
s_catow.c 538ae5a 1222
|
||||
s_cmp.c ff4f2982 655
|
||||
s_copy.c f50c7ec9 397
|
||||
s_paus.c e726a719 1552
|
||||
s_rnge.c 1d6cada2 680
|
||||
s_stop.c 1f5aaac8 511
|
||||
sig_die.c e934624a 634
|
||||
signal_.c 1b0b75f3 327
|
||||
system_.c c910b8a 396
|
||||
z_abs.c f71a28c1 201
|
||||
z_cos.c 110bc444 269
|
||||
z_div.c ff56b823 675
|
||||
z_exp.c ced892b 278
|
||||
z_log.c 4ea97f4 305
|
||||
z_sin.c 1215f0b4 267
|
||||
z_sqrt.c e8d24b0 492
|
128
lib/libF77/main.c
Normal file
128
lib/libF77/main.c
Normal file
@ -0,0 +1,128 @@
|
||||
/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */
|
||||
|
||||
#include "stdio.h"
|
||||
#include "signal.h"
|
||||
|
||||
#ifndef SIGIOT
|
||||
#ifdef SIGABRT
|
||||
#define SIGIOT SIGABRT
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef KR_headers
|
||||
#include "stdlib.h"
|
||||
#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(Int n)
|
||||
{
|
||||
sig_die("Floating Exception", 1);
|
||||
}
|
||||
|
||||
|
||||
static void sigidie(Int n)
|
||||
{
|
||||
sig_die("IOT Trap", 1);
|
||||
}
|
||||
|
||||
#ifdef SIGQUIT
|
||||
static void sigqdie(Int n)
|
||||
{
|
||||
sig_die("Quit signal", 1);
|
||||
}
|
||||
#endif
|
||||
|
||||
|
||||
static void sigindie(Int n)
|
||||
{
|
||||
sig_die("Interrupt", 0);
|
||||
}
|
||||
|
||||
static void sigtdie(Int n)
|
||||
{
|
||||
sig_die("Killed", 0);
|
||||
}
|
||||
|
||||
#ifdef SIGTRAP
|
||||
static void sigtrdie(Int n)
|
||||
{
|
||||
sig_die("Trace trap", 1);
|
||||
}
|
||||
#endif
|
||||
|
||||
|
||||
int xargc;
|
||||
char **xargv;
|
||||
|
||||
#ifdef KR_headers
|
||||
main(argc, argv) int argc; char **argv;
|
||||
#else
|
||||
main(int argc, char **argv)
|
||||
#endif
|
||||
{
|
||||
xargc = argc;
|
||||
xargv = argv;
|
||||
signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
|
||||
#ifdef SIGIOT
|
||||
signal(SIGIOT, sigidie);
|
||||
#endif
|
||||
#ifdef SIGTRAP
|
||||
signal(SIGTRAP, sigtrdie);
|
||||
#endif
|
||||
#ifdef SIGQUIT
|
||||
if(signal(SIGQUIT,sigqdie) == SIG_IGN)
|
||||
signal(SIGQUIT, SIG_IGN);
|
||||
#endif
|
||||
if(signal(SIGINT, sigindie) == SIG_IGN)
|
||||
signal(SIGINT, SIG_IGN);
|
||||
signal(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. */
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
78
lib/libF77/makefile
Normal file
78
lib/libF77/makefile
Normal file
@ -0,0 +1,78 @@
|
||||
.SUFFIXES: .c .o
|
||||
CC = cc
|
||||
SHELL = /bin/sh
|
||||
CFLAGS = -O
|
||||
|
||||
# If your system lacks onexit() and you are not using an
|
||||
# ANSI C compiler, then you should add -DNO_ONEXIT to CFLAGS,
|
||||
# e.g., by changing the above "CFLAGS =" line to
|
||||
# CFLAGS = -O -DNO_ONEXIT
|
||||
|
||||
# On at least some Sun systems, it is more appropriate to change the
|
||||
# "CFLAGS =" line to
|
||||
# CFLAGS = -O -Donexit=on_exit
|
||||
|
||||
# compile, then strip unnecessary symbols
|
||||
.c.o:
|
||||
$(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c
|
||||
ld -r -x -o $*.xxx $*.o
|
||||
mv $*.xxx $*.o
|
||||
|
||||
MISC = Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o getenv_.o\
|
||||
signal_.o s_stop.o s_paus.o system_.o cabs.o\
|
||||
derf_.o derfc_.o erf_.o erfc_.o sig_die.o
|
||||
POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o
|
||||
CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
|
||||
DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
|
||||
REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
|
||||
r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
|
||||
r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
|
||||
r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
|
||||
DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
|
||||
d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
|
||||
d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
|
||||
d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
|
||||
d_sqrt.o d_tan.o d_tanh.o
|
||||
INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o
|
||||
HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o
|
||||
CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o
|
||||
EFL = ef1asc_.o ef1cmc_.o
|
||||
CHAR = s_cat.o s_cmp.o s_copy.o
|
||||
|
||||
libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
|
||||
$(HALF) $(CMP) $(EFL) $(CHAR)
|
||||
ar r libF77.a $?
|
||||
ranlib libF77.a
|
||||
|
||||
Version.o: Version.c
|
||||
$(CC) -c Version.c
|
||||
|
||||
# To compile with C++, first "make f2c.h"
|
||||
f2c.h: f2ch.add
|
||||
cat /usr/include/f2c.h f2ch.add >f2c.h
|
||||
|
||||
install: libF77.a
|
||||
mv libF77.a /usr/lib
|
||||
|
||||
clean:
|
||||
rm -f libF77.a *.o
|
||||
|
||||
check:
|
||||
xsum Notice README Version.c abort_.c c_abs.c c_cos.c c_div.c \
|
||||
c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \
|
||||
d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \
|
||||
d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \
|
||||
d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \
|
||||
derf_.c derfc_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c f2ch.add \
|
||||
getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \
|
||||
h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \
|
||||
i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c \
|
||||
i_sign.c iargc_.c l_ge.c l_gt.c l_le.c l_lt.c main.c makefile \
|
||||
pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c \
|
||||
pow_zi.c pow_zz.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \
|
||||
r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \
|
||||
r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \
|
||||
r_tan.c r_tanh.c s_cat.c s_catow.c s_cmp.c s_copy.c s_paus.c s_rnge.c \
|
||||
s_stop.c sig_die.c signal_.c system_.c z_abs.c z_cos.c z_div.c \
|
||||
z_exp.c z_log.c z_sin.c z_sqrt.c >zap
|
||||
cmp zap libF77.xsum && rm zap || diff libF77.xsum zap
|
20
lib/libF77/pow_ci.c
Normal file
20
lib/libF77/pow_ci.c
Normal file
@ -0,0 +1,20 @@
|
||||
#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
Normal file
13
lib/libF77/pow_dd.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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) );
|
||||
}
|
34
lib/libF77/pow_di.c
Normal file
34
lib/libF77/pow_di.c
Normal file
@ -0,0 +1,34 @@
|
||||
#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;
|
||||
|
||||
pow = 1;
|
||||
x = *ap;
|
||||
n = *bp;
|
||||
|
||||
if(n != 0)
|
||||
{
|
||||
if(n < 0)
|
||||
{
|
||||
n = -n;
|
||||
x = 1/x;
|
||||
}
|
||||
for( ; ; )
|
||||
{
|
||||
if(n & 01)
|
||||
pow *= x;
|
||||
if(n >>= 1)
|
||||
x *= x;
|
||||
else
|
||||
break;
|
||||
}
|
||||
}
|
||||
return(pow);
|
||||
}
|
31
lib/libF77/pow_hh.c
Normal file
31
lib/libF77/pow_hh.c
Normal file
@ -0,0 +1,31 @@
|
||||
#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;
|
||||
|
||||
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;
|
||||
}
|
||||
for(pow = 1; ; )
|
||||
{
|
||||
if(n & 01)
|
||||
pow *= x;
|
||||
if(n >>= 1)
|
||||
x *= x;
|
||||
else
|
||||
break;
|
||||
}
|
||||
return(pow);
|
||||
}
|
31
lib/libF77/pow_ii.c
Normal file
31
lib/libF77/pow_ii.c
Normal file
@ -0,0 +1,31 @@
|
||||
#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;
|
||||
|
||||
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;
|
||||
}
|
||||
for(pow = 1; ; )
|
||||
{
|
||||
if(n & 01)
|
||||
pow *= x;
|
||||
if(n >>= 1)
|
||||
x *= x;
|
||||
else
|
||||
break;
|
||||
}
|
||||
return(pow);
|
||||
}
|
31
lib/libF77/pow_qq.c
Normal file
31
lib/libF77/pow_qq.c
Normal file
@ -0,0 +1,31 @@
|
||||
#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;
|
||||
|
||||
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;
|
||||
}
|
||||
for(pow = 1; ; )
|
||||
{
|
||||
if(n & 01)
|
||||
pow *= x;
|
||||
if(n >>= 1)
|
||||
x *= x;
|
||||
else
|
||||
break;
|
||||
}
|
||||
return(pow);
|
||||
}
|
34
lib/libF77/pow_ri.c
Normal file
34
lib/libF77/pow_ri.c
Normal file
@ -0,0 +1,34 @@
|
||||
#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;
|
||||
|
||||
pow = 1;
|
||||
x = *ap;
|
||||
n = *bp;
|
||||
|
||||
if(n != 0)
|
||||
{
|
||||
if(n < 0)
|
||||
{
|
||||
n = -n;
|
||||
x = 1/x;
|
||||
}
|
||||
for( ; ; )
|
||||
{
|
||||
if(n & 01)
|
||||
pow *= x;
|
||||
if(n >>= 1)
|
||||
x *= x;
|
||||
else
|
||||
break;
|
||||
}
|
||||
}
|
||||
return(pow);
|
||||
}
|
50
lib/libF77/pow_zi.c
Normal file
50
lib/libF77/pow_zi.c
Normal file
@ -0,0 +1,50 @@
|
||||
#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;
|
||||
double t;
|
||||
doublecomplex x;
|
||||
static doublecomplex one = {1.0, 0.0};
|
||||
|
||||
n = *b;
|
||||
p->r = 1;
|
||||
p->i = 0;
|
||||
|
||||
if(n == 0)
|
||||
return;
|
||||
if(n < 0)
|
||||
{
|
||||
n = -n;
|
||||
z_div(&x, &one, a);
|
||||
}
|
||||
else
|
||||
{
|
||||
x.r = a->r;
|
||||
x.i = a->i;
|
||||
}
|
||||
|
||||
for( ; ; )
|
||||
{
|
||||
if(n & 01)
|
||||
{
|
||||
t = p->r * x.r - p->i * x.i;
|
||||
p->i = p->r * x.i + p->i * x.r;
|
||||
p->r = t;
|
||||
}
|
||||
if(n >>= 1)
|
||||
{
|
||||
t = x.r * x.r - x.i * x.i;
|
||||
x.i = 2 * x.r * x.i;
|
||||
x.r = t;
|
||||
}
|
||||
else
|
||||
break;
|
||||
}
|
||||
}
|
23
lib/libF77/pow_zz.c
Normal file
23
lib/libF77/pow_zz.c
Normal file
@ -0,0 +1,23 @@
|
||||
#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
Normal file
12
lib/libF77/r_abs.c
Normal file
@ -0,0 +1,12 @@
|
||||
#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
Normal file
13
lib/libF77/r_acos.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/r_asin.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/r_atan.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/r_atn2.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
11
lib/libF77/r_cnjg.c
Normal file
@ -0,0 +1,11 @@
|
||||
#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
Normal file
13
lib/libF77/r_cos.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
13
lib/libF77/r_cosh.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
10
lib/libF77/r_dim.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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
Normal file
13
lib/libF77/r_exp.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
10
lib/libF77/r_imag.c
Normal file
@ -0,0 +1,10 @@
|
||||
#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
Normal file
13
lib/libF77/r_int.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
15
lib/libF77/r_lg10.c
Normal file
@ -0,0 +1,15 @@
|
||||
#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
Normal file
13
lib/libF77/r_log.c
Normal file
@ -0,0 +1,13 @@
|
||||
#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
Normal file
40
lib/libF77/r_mod.c
Normal file
@ -0,0 +1,40 @@
|
||||
#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
Normal file
14
lib/libF77/r_nint.c
Normal file
@ -0,0 +1,14 @@
|
||||
#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) );
|
||||
}
|
12
lib/libF77/r_sign.c
Normal file
12
lib/libF77/r_sign.c
Normal file
@ -0,0 +1,12 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double r_sign(a,b) real *a, *b;
|
||||
#else
|
||||
double r_sign(real *a, real *b)
|
||||
#endif
|
||||
{
|
||||
double x;
|
||||
x = (*a >= 0 ? *a : - *a);
|
||||
return( *b >= 0 ? x : -x);
|
||||
}
|
13
lib/libF77/r_sin.c
Normal file
13
lib/libF77/r_sin.c
Normal file
@ -0,0 +1,13 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double sin();
|
||||
double r_sin(x) real *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
double r_sin(real *x)
|
||||
#endif
|
||||
{
|
||||
return( sin(*x) );
|
||||
}
|
13
lib/libF77/r_sinh.c
Normal file
13
lib/libF77/r_sinh.c
Normal file
@ -0,0 +1,13 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double sinh();
|
||||
double r_sinh(x) real *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
double r_sinh(real *x)
|
||||
#endif
|
||||
{
|
||||
return( sinh(*x) );
|
||||
}
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user