diff options
author | Jeff Law <law@gcc.gnu.org> | 1998-01-31 18:37:08 -0700 |
---|---|---|
committer | Jeff Law <law@gcc.gnu.org> | 1998-01-31 18:37:08 -0700 |
commit | 81fea2b1d147752f431b46c08f4c12a18a2d78bc (patch) | |
tree | 4b30cdf598ee6a8b24903fba52bb3e0c06bf459b /libf2c/libF77 | |
parent | 0dfb6849ef1d4c8b5bf178d7add69ab297fab8fa (diff) | |
download | gcc-81fea2b1d147752f431b46c08f4c12a18a2d78bc.tar.gz |
* Previous contents of gcc/f/runtime moved into toplevel
"libf2c" directory.
From-SVN: r17568
Diffstat (limited to 'libf2c/libF77')
129 files changed, 3214 insertions, 0 deletions
diff --git a/libf2c/libF77/F77_aloc.c b/libf2c/libF77/F77_aloc.c new file mode 100644 index 00000000000..8754fe2ef70 --- /dev/null +++ b/libf2c/libF77/F77_aloc.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#undef abs +#undef min +#undef max +#include <stdio.h> + +static integer memfailure = 3; + +#ifdef KR_headers +extern char *malloc(); +extern void G77_exit_0 (); + + char * +F77_aloc(Len, whence) integer Len; char *whence; +#else +#include <stdlib.h> +extern void G77_exit_0 (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); + G77_exit_0 (&memfailure); + } + return rv; + } diff --git a/libf2c/libF77/Makefile.in b/libf2c/libF77/Makefile.in new file mode 100644 index 00000000000..266e22b72cf --- /dev/null +++ b/libf2c/libF77/Makefile.in @@ -0,0 +1,76 @@ +# Makefile for GNU F77 compiler runtime. +# Copyright 1990 - 1994 by AT&T Bell Laboratories and Bellcore (see the +# file `Notice'). +# Portions of this file Copyright (C) 1995, 1996 Free Software Foundation, Inc. +# Contributed by Dave Love (d.love@dl.ac.uk). +# +#This file is part of GNU Fortran. +# +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. +# +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. +# +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +SHELL = /bin/sh + +srcdir = @srcdir@ +VPATH = @srcdir@ + +#### Start of system configuration section. #### + + +.c.o: + $(CC) -c -DSkip_f2c_Undefs -I../ $(CFLAGS) $< + +MISC = F77_aloc.o VersionF.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 exit_.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 \ + pow_qq.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 +F90BIT = lbitbits.o lbitshft.o qbitbits.o qbitshft.o + +F2C_H = ../f2c.h + +all: $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT) + +VersionF.o: Version.c + $(CC) -c $(CFLAGS) -o $@ $(srcdir)/Version.c + +mostlyclean clean: + -rm -f *.o + +distclean maintainer-clean: clean + -rm -f stage? include Makefile + +# Not quite all these actually do depend on f2c.h... +$(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT): $(F2C_H) + +.PHONY: mostlyclean clean distclean maintainer-clean all diff --git a/libf2c/libF77/Notice b/libf2c/libF77/Notice new file mode 100644 index 00000000000..261b719bc57 --- /dev/null +++ b/libf2c/libF77/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/libf2c/libF77/README.netlib b/libf2c/libF77/README.netlib new file mode 100644 index 00000000000..76682152551 --- /dev/null +++ b/libf2c/libF77/README.netlib @@ -0,0 +1,108 @@ +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 diff --git a/libf2c/libF77/Version.c b/libf2c/libF77/Version.c new file mode 100644 index 00000000000..7bb09729c47 --- /dev/null +++ b/libf2c/libF77/Version.c @@ -0,0 +1,67 @@ +static char junk[] = "\n@(#)LIBF77 VERSION 19970919\n"; + +/* +*/ + +char __G77_LIBF77_VERSION__[] = "0.5.21"; + +/* +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. +*/ + +#include <stdio.h> + +void +g77__fvers__ () +{ + fprintf (stderr, "__G77_LIBF77_VERSION__: %s", __G77_LIBF77_VERSION__); + fputs (junk, stderr); +} diff --git a/libf2c/libF77/abort_.c b/libf2c/libF77/abort_.c new file mode 100644 index 00000000000..8efdc42f970 --- /dev/null +++ b/libf2c/libF77/abort_.c @@ -0,0 +1,18 @@ +#include <stdio.h> +#include "f2c.h" + +#ifdef KR_headers +extern VOID sig_die(); + +int G77_abort_0 () +#else +extern void sig_die(char*,int); + +int G77_abort_0 (void) +#endif +{ +sig_die("Fortran abort routine called", 1); +#ifdef __cplusplus +return 0; +#endif +} diff --git a/libf2c/libF77/c_abs.c b/libf2c/libF77/c_abs.c new file mode 100644 index 00000000000..041fbd3d8bb --- /dev/null +++ b/libf2c/libF77/c_abs.c @@ -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 ) ); +} diff --git a/libf2c/libF77/c_cos.c b/libf2c/libF77/c_cos.c new file mode 100644 index 00000000000..9e833c168b3 --- /dev/null +++ b/libf2c/libF77/c_cos.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_cos(resx, z) complex *resx, *z; +#else +#undef abs +#include <math.h> + +void c_cos(complex *resx, complex *z) +#endif +{ +complex res; + +res.r = cos(z->r) * cosh(z->i); +res.i = - sin(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/c_div.c b/libf2c/libF77/c_div.c new file mode 100644 index 00000000000..9568354bd53 --- /dev/null +++ b/libf2c/libF77/c_div.c @@ -0,0 +1,40 @@ +#include "f2c.h" + +#ifdef KR_headers +extern VOID sig_die(); +VOID c_div(resx, a, b) +complex *a, *b, *resx; +#else +extern void sig_die(char*,int); +void c_div(complex *resx, complex *a, complex *b) +#endif +{ +double ratio, den; +double abr, abi; +complex res; + +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); + res.r = (a->r*ratio + a->i) / den; + res.i = (a->i*ratio - a->r) / den; + } + +else + { + ratio = (double)b->i / b->r ; + den = b->r * (1 + ratio*ratio); + res.r = (a->r + a->i*ratio) / den; + res.i = (a->i - a->r*ratio) / den; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/c_exp.c b/libf2c/libF77/c_exp.c new file mode 100644 index 00000000000..8d3d33d0fe3 --- /dev/null +++ b/libf2c/libF77/c_exp.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double exp(), cos(), sin(); + + VOID c_exp(resx, z) complex *resx, *z; +#else +#undef abs +#include <math.h> + +void c_exp(complex *resx, complex *z) +#endif +{ +double expx; +complex res; + +expx = exp(z->r); +res.r = expx * cos(z->i); +res.i = expx * sin(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/c_log.c b/libf2c/libF77/c_log.c new file mode 100644 index 00000000000..6715131ad1d --- /dev/null +++ b/libf2c/libF77/c_log.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double log(), f__cabs(), atan2(); +VOID c_log(resx, z) complex *resx, *z; +#else +#undef abs +#include <math.h> +extern double f__cabs(double, double); + +void c_log(complex *resx, complex *z) +#endif +{ +complex res; + +res.i = atan2(z->i, z->r); +res.r = log( f__cabs(z->r, z->i) ); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/c_sin.c b/libf2c/libF77/c_sin.c new file mode 100644 index 00000000000..7bf3e392bed --- /dev/null +++ b/libf2c/libF77/c_sin.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_sin(resx, z) complex *resx, *z; +#else +#undef abs +#include <math.h> + +void c_sin(complex *resx, complex *z) +#endif +{ +complex res; + +res.r = sin(z->r) * cosh(z->i); +res.i = cos(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/c_sqrt.c b/libf2c/libF77/c_sqrt.c new file mode 100644 index 00000000000..775977a87f7 --- /dev/null +++ b/libf2c/libF77/c_sqrt.c @@ -0,0 +1,38 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sqrt(), f__cabs(); + +VOID c_sqrt(resx, z) complex *resx, *z; +#else +#undef abs +#include <math.h> +extern double f__cabs(double, double); + +void c_sqrt(complex *resx, complex *z) +#endif +{ +double mag, t; +complex res; + +if( (mag = f__cabs(z->r, z->i)) == 0.) + res.r = res.i = 0.; +else if(z->r > 0) + { + res.r = t = sqrt(0.5 * (mag + z->r) ); + t = z->i / t; + res.i = 0.5 * t; + } +else + { + t = sqrt(0.5 * (mag - z->r) ); + if(z->i < 0) + t = -t; + res.i = t; + t = z->i / t; + res.r = 0.5 * t; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/cabs.c b/libf2c/libF77/cabs.c new file mode 100644 index 00000000000..2fad044e884 --- /dev/null +++ b/libf2c/libF77/cabs.c @@ -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); +} diff --git a/libf2c/libF77/d_abs.c b/libf2c/libF77/d_abs.c new file mode 100644 index 00000000000..cb157e067b7 --- /dev/null +++ b/libf2c/libF77/d_abs.c @@ -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); +} diff --git a/libf2c/libF77/d_acos.c b/libf2c/libF77/d_acos.c new file mode 100644 index 00000000000..33da5369db2 --- /dev/null +++ b/libf2c/libF77/d_acos.c @@ -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) ); +} diff --git a/libf2c/libF77/d_asin.c b/libf2c/libF77/d_asin.c new file mode 100644 index 00000000000..79b33ca1bd6 --- /dev/null +++ b/libf2c/libF77/d_asin.c @@ -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) ); +} diff --git a/libf2c/libF77/d_atan.c b/libf2c/libF77/d_atan.c new file mode 100644 index 00000000000..caea4a406e0 --- /dev/null +++ b/libf2c/libF77/d_atan.c @@ -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) ); +} diff --git a/libf2c/libF77/d_atn2.c b/libf2c/libF77/d_atn2.c new file mode 100644 index 00000000000..6748a55d56f --- /dev/null +++ b/libf2c/libF77/d_atn2.c @@ -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) ); +} diff --git a/libf2c/libF77/d_cnjg.c b/libf2c/libF77/d_cnjg.c new file mode 100644 index 00000000000..1afa3bc4061 --- /dev/null +++ b/libf2c/libF77/d_cnjg.c @@ -0,0 +1,17 @@ +#include "f2c.h" + + VOID +#ifdef KR_headers +d_cnjg(resx, z) doublecomplex *resx, *z; +#else +d_cnjg(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.r = z->r; +res.i = - z->i; + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/d_cos.c b/libf2c/libF77/d_cos.c new file mode 100644 index 00000000000..fa4d6ca406f --- /dev/null +++ b/libf2c/libF77/d_cos.c @@ -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) ); +} diff --git a/libf2c/libF77/d_cosh.c b/libf2c/libF77/d_cosh.c new file mode 100644 index 00000000000..edc0ebc1092 --- /dev/null +++ b/libf2c/libF77/d_cosh.c @@ -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) ); +} diff --git a/libf2c/libF77/d_dim.c b/libf2c/libF77/d_dim.c new file mode 100644 index 00000000000..1d0ecb7bbb6 --- /dev/null +++ b/libf2c/libF77/d_dim.c @@ -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); +} diff --git a/libf2c/libF77/d_exp.c b/libf2c/libF77/d_exp.c new file mode 100644 index 00000000000..be12fd70551 --- /dev/null +++ b/libf2c/libF77/d_exp.c @@ -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) ); +} diff --git a/libf2c/libF77/d_imag.c b/libf2c/libF77/d_imag.c new file mode 100644 index 00000000000..793a3f9c405 --- /dev/null +++ b/libf2c/libF77/d_imag.c @@ -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); +} diff --git a/libf2c/libF77/d_int.c b/libf2c/libF77/d_int.c new file mode 100644 index 00000000000..beff1e7d378 --- /dev/null +++ b/libf2c/libF77/d_int.c @@ -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) ); +} diff --git a/libf2c/libF77/d_lg10.c b/libf2c/libF77/d_lg10.c new file mode 100644 index 00000000000..c0892bd512a --- /dev/null +++ b/libf2c/libF77/d_lg10.c @@ -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) ); +} diff --git a/libf2c/libF77/d_log.c b/libf2c/libF77/d_log.c new file mode 100644 index 00000000000..592015b2821 --- /dev/null +++ b/libf2c/libF77/d_log.c @@ -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) ); +} diff --git a/libf2c/libF77/d_mod.c b/libf2c/libF77/d_mod.c new file mode 100644 index 00000000000..23f19299168 --- /dev/null +++ b/libf2c/libF77/d_mod.c @@ -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 +} diff --git a/libf2c/libF77/d_nint.c b/libf2c/libF77/d_nint.c new file mode 100644 index 00000000000..064beff669c --- /dev/null +++ b/libf2c/libF77/d_nint.c @@ -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) ); +} diff --git a/libf2c/libF77/d_prod.c b/libf2c/libF77/d_prod.c new file mode 100644 index 00000000000..3d4cef7835c --- /dev/null +++ b/libf2c/libF77/d_prod.c @@ -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) ); +} diff --git a/libf2c/libF77/d_sign.c b/libf2c/libF77/d_sign.c new file mode 100644 index 00000000000..514ff0bbff8 --- /dev/null +++ b/libf2c/libF77/d_sign.c @@ -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); +} diff --git a/libf2c/libF77/d_sin.c b/libf2c/libF77/d_sin.c new file mode 100644 index 00000000000..fdd699eede5 --- /dev/null +++ b/libf2c/libF77/d_sin.c @@ -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) ); +} diff --git a/libf2c/libF77/d_sinh.c b/libf2c/libF77/d_sinh.c new file mode 100644 index 00000000000..77f36904f8e --- /dev/null +++ b/libf2c/libF77/d_sinh.c @@ -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) ); +} diff --git a/libf2c/libF77/d_sqrt.c b/libf2c/libF77/d_sqrt.c new file mode 100644 index 00000000000..b5cf83b946f --- /dev/null +++ b/libf2c/libF77/d_sqrt.c @@ -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) ); +} diff --git a/libf2c/libF77/d_tan.c b/libf2c/libF77/d_tan.c new file mode 100644 index 00000000000..af94a053223 --- /dev/null +++ b/libf2c/libF77/d_tan.c @@ -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) ); +} diff --git a/libf2c/libF77/d_tanh.c b/libf2c/libF77/d_tanh.c new file mode 100644 index 00000000000..92a02d4fd6b --- /dev/null +++ b/libf2c/libF77/d_tanh.c @@ -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) ); +} diff --git a/libf2c/libF77/derf_.c b/libf2c/libF77/derf_.c new file mode 100644 index 00000000000..fba6b6b11f3 --- /dev/null +++ b/libf2c/libF77/derf_.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double erf(); +double G77_derf_0 (x) doublereal *x; +#else +extern double erf(double); +double G77_derf_0 (doublereal *x) +#endif +{ +return( erf(*x) ); +} diff --git a/libf2c/libF77/derfc_.c b/libf2c/libF77/derfc_.c new file mode 100644 index 00000000000..ae1ac740302 --- /dev/null +++ b/libf2c/libF77/derfc_.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double erfc(); + +double G77_derfc_0 (x) doublereal *x; +#else +extern double erfc(double); + +double G77_derfc_0 (doublereal *x) +#endif +{ +return( erfc(*x) ); +} diff --git a/libf2c/libF77/dtime_.c b/libf2c/libF77/dtime_.c new file mode 100644 index 00000000000..79b6735b13b --- /dev/null +++ b/libf2c/libF77/dtime_.c @@ -0,0 +1,45 @@ +#include "time.h" +#ifndef USE_CLOCK +#include "sys/types.h" +#include "sys/times.h" +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + double +#ifdef KR_headers +dtime_(tarray) float *tarray; +#else +dtime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + static double t0; + double t = clock(); + tarray[1] = 0; + tarray[0] = (t - t0) / CLOCKS_PER_SECOND; + t0 = t; + return tarray[0]; +#else + struct tms t; + static struct tms t0; + + times(&t); + tarray[0] = (t.tms_utime - t0.tms_utime) / Hz; + tarray[1] = (t.tms_stime - t0.tms_stime) / Hz; + t0 = t; + return tarray[0] + tarray[1]; +#endif + } diff --git a/libf2c/libF77/ef1asc_.c b/libf2c/libF77/ef1asc_.c new file mode 100644 index 00000000000..a922a1d9ba9 --- /dev/null +++ b/libf2c/libF77/ef1asc_.c @@ -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(); +G77_ef1asc_0 (a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern void s_copy(char*,char*,ftnlen,ftnlen); +int G77_ef1asc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +#ifdef __cplusplus +return 0; +#endif +} diff --git a/libf2c/libF77/ef1cmc_.c b/libf2c/libF77/ef1cmc_.c new file mode 100644 index 00000000000..f471172935f --- /dev/null +++ b/libf2c/libF77/ef1cmc_.c @@ -0,0 +1,14 @@ +/* EFL support routine to compare two character strings */ + +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +integer G77_ef1cmc_0 (a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern integer s_cmp(char*,char*,ftnlen,ftnlen); +integer G77_ef1cmc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +} diff --git a/libf2c/libF77/erf_.c b/libf2c/libF77/erf_.c new file mode 100644 index 00000000000..1ba4350ad05 --- /dev/null +++ b/libf2c/libF77/erf_.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double erf(); +double G77_erf_0 (x) real *x; +#else +extern double erf(double); +double G77_erf_0 (real *x) +#endif +{ +return( erf(*x) ); +} diff --git a/libf2c/libF77/erfc_.c b/libf2c/libF77/erfc_.c new file mode 100644 index 00000000000..f44b1d49d84 --- /dev/null +++ b/libf2c/libF77/erfc_.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double erfc(); +double G77_erfc_0 (x) real *x; +#else +extern double erfc(double); +double G77_erfc_0 (real *x) +#endif +{ +return( erfc(*x) ); +} diff --git a/libf2c/libF77/etime_.c b/libf2c/libF77/etime_.c new file mode 100644 index 00000000000..04528b50bb8 --- /dev/null +++ b/libf2c/libF77/etime_.c @@ -0,0 +1,38 @@ +#include "time.h" +#ifndef USE_CLOCK +#include "sys/types.h" +#include "sys/times.h" +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + double +#ifdef KR_headers +etime_(tarray) float *tarray; +#else +etime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + double t = clock(); + tarray[1] = 0; + return tarray[0] = t / CLOCKS_PER_SECOND; +#else + struct tms t; + + times(&t); + return (tarray[0] = t.tms_utime/Hz) + (tarray[1] = t.tms_stime/Hz); +#endif + } diff --git a/libf2c/libF77/exit_.c b/libf2c/libF77/exit_.c new file mode 100644 index 00000000000..4c0582add12 --- /dev/null +++ b/libf2c/libF77/exit_.c @@ -0,0 +1,37 @@ +/* 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 +G77_exit_0 (rc) integer *rc; +#else +G77_exit_0 (integer *rc) +#endif +{ +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(*rc); + } +#ifdef __cplusplus +} +#endif diff --git a/libf2c/libF77/f2ch.add b/libf2c/libF77/f2ch.add new file mode 100644 index 00000000000..a2acc17a159 --- /dev/null +++ b/libf2c/libF77/f2ch.add @@ -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 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 diff --git a/libf2c/libF77/getarg_.c b/libf2c/libF77/getarg_.c new file mode 100644 index 00000000000..eaded2e4c9b --- /dev/null +++ b/libf2c/libF77/getarg_.c @@ -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 G77_getarg_0 (n, s, ls) ftnint *n; register char *s; ftnlen ls; +#else +void G77_getarg_0 (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++ = ' '; +} diff --git a/libf2c/libF77/getenv_.c b/libf2c/libF77/getenv_.c new file mode 100644 index 00000000000..b9916e6065e --- /dev/null +++ b/libf2c/libF77/getenv_.c @@ -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 G77_getenv_0 (fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen; +#else +void G77_getenv_0 (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++ = ' '; +} diff --git a/libf2c/libF77/h_abs.c b/libf2c/libF77/h_abs.c new file mode 100644 index 00000000000..73b82151ac1 --- /dev/null +++ b/libf2c/libF77/h_abs.c @@ -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); +} diff --git a/libf2c/libF77/h_dim.c b/libf2c/libF77/h_dim.c new file mode 100644 index 00000000000..ceff660e26c --- /dev/null +++ b/libf2c/libF77/h_dim.c @@ -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); +} diff --git a/libf2c/libF77/h_dnnt.c b/libf2c/libF77/h_dnnt.c new file mode 100644 index 00000000000..9d0aa25f1d3 --- /dev/null +++ b/libf2c/libF77/h_dnnt.c @@ -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) ); +} diff --git a/libf2c/libF77/h_indx.c b/libf2c/libF77/h_indx.c new file mode 100644 index 00000000000..a211cc7fa0f --- /dev/null +++ b/libf2c/libF77/h_indx.c @@ -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); +} diff --git a/libf2c/libF77/h_len.c b/libf2c/libF77/h_len.c new file mode 100644 index 00000000000..00a2151bfa1 --- /dev/null +++ b/libf2c/libF77/h_len.c @@ -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); +} diff --git a/libf2c/libF77/h_mod.c b/libf2c/libF77/h_mod.c new file mode 100644 index 00000000000..43431c1c503 --- /dev/null +++ b/libf2c/libF77/h_mod.c @@ -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); +} diff --git a/libf2c/libF77/h_nint.c b/libf2c/libF77/h_nint.c new file mode 100644 index 00000000000..0af3735da42 --- /dev/null +++ b/libf2c/libF77/h_nint.c @@ -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) ); +} diff --git a/libf2c/libF77/h_sign.c b/libf2c/libF77/h_sign.c new file mode 100644 index 00000000000..7b06c157a74 --- /dev/null +++ b/libf2c/libF77/h_sign.c @@ -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); +} diff --git a/libf2c/libF77/hl_ge.c b/libf2c/libF77/hl_ge.c new file mode 100644 index 00000000000..4c29527065a --- /dev/null +++ b/libf2c/libF77/hl_ge.c @@ -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); +} diff --git a/libf2c/libF77/hl_gt.c b/libf2c/libF77/hl_gt.c new file mode 100644 index 00000000000..c4f345a0859 --- /dev/null +++ b/libf2c/libF77/hl_gt.c @@ -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); +} diff --git a/libf2c/libF77/hl_le.c b/libf2c/libF77/hl_le.c new file mode 100644 index 00000000000..a9cce596c71 --- /dev/null +++ b/libf2c/libF77/hl_le.c @@ -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); +} diff --git a/libf2c/libF77/hl_lt.c b/libf2c/libF77/hl_lt.c new file mode 100644 index 00000000000..162d919c3b4 --- /dev/null +++ b/libf2c/libF77/hl_lt.c @@ -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); +} diff --git a/libf2c/libF77/i_abs.c b/libf2c/libF77/i_abs.c new file mode 100644 index 00000000000..be21295aaa1 --- /dev/null +++ b/libf2c/libF77/i_abs.c @@ -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); +} diff --git a/libf2c/libF77/i_dim.c b/libf2c/libF77/i_dim.c new file mode 100644 index 00000000000..6e1b1707b55 --- /dev/null +++ b/libf2c/libF77/i_dim.c @@ -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); +} diff --git a/libf2c/libF77/i_dnnt.c b/libf2c/libF77/i_dnnt.c new file mode 100644 index 00000000000..8fcecb68200 --- /dev/null +++ b/libf2c/libF77/i_dnnt.c @@ -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) ); +} diff --git a/libf2c/libF77/i_indx.c b/libf2c/libF77/i_indx.c new file mode 100644 index 00000000000..96e7bc51ba8 --- /dev/null +++ b/libf2c/libF77/i_indx.c @@ -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); +} diff --git a/libf2c/libF77/i_len.c b/libf2c/libF77/i_len.c new file mode 100644 index 00000000000..4020fee4618 --- /dev/null +++ b/libf2c/libF77/i_len.c @@ -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); +} diff --git a/libf2c/libF77/i_mod.c b/libf2c/libF77/i_mod.c new file mode 100644 index 00000000000..6937c421357 --- /dev/null +++ b/libf2c/libF77/i_mod.c @@ -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); +} diff --git a/libf2c/libF77/i_nint.c b/libf2c/libF77/i_nint.c new file mode 100644 index 00000000000..c0f6795171f --- /dev/null +++ b/libf2c/libF77/i_nint.c @@ -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) ); +} diff --git a/libf2c/libF77/i_sign.c b/libf2c/libF77/i_sign.c new file mode 100644 index 00000000000..94009b86e6f --- /dev/null +++ b/libf2c/libF77/i_sign.c @@ -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); +} diff --git a/libf2c/libF77/iargc_.c b/libf2c/libF77/iargc_.c new file mode 100644 index 00000000000..7ce5e08d306 --- /dev/null +++ b/libf2c/libF77/iargc_.c @@ -0,0 +1,11 @@ +#include "f2c.h" + +#ifdef KR_headers +ftnint G77_iargc_0 () +#else +ftnint G77_iargc_0 (void) +#endif +{ +extern int xargc; +return ( xargc - 1 ); +} diff --git a/libf2c/libF77/l_ge.c b/libf2c/libF77/l_ge.c new file mode 100644 index 00000000000..86b4a1f5a7f --- /dev/null +++ b/libf2c/libF77/l_ge.c @@ -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); +} diff --git a/libf2c/libF77/l_gt.c b/libf2c/libF77/l_gt.c new file mode 100644 index 00000000000..c4b52f5bf7d --- /dev/null +++ b/libf2c/libF77/l_gt.c @@ -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); +} diff --git a/libf2c/libF77/l_le.c b/libf2c/libF77/l_le.c new file mode 100644 index 00000000000..f2740a23814 --- /dev/null +++ b/libf2c/libF77/l_le.c @@ -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); +} diff --git a/libf2c/libF77/l_lt.c b/libf2c/libF77/l_lt.c new file mode 100644 index 00000000000..c48dc946f9a --- /dev/null +++ b/libf2c/libF77/l_lt.c @@ -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); +} diff --git a/libf2c/libF77/lbitbits.c b/libf2c/libF77/lbitbits.c new file mode 100644 index 00000000000..75e9f9c603f --- /dev/null +++ b/libf2c/libF77/lbitbits.c @@ -0,0 +1,62 @@ +#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)); + } diff --git a/libf2c/libF77/lbitshft.c b/libf2c/libF77/lbitshft.c new file mode 100644 index 00000000000..81b0fdbeaba --- /dev/null +++ b/libf2c/libF77/lbitshft.c @@ -0,0 +1,11 @@ +#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); + } diff --git a/libf2c/libF77/main.c b/libf2c/libF77/main.c new file mode 100644 index 00000000000..469a64bdcb3 --- /dev/null +++ b/libf2c/libF77/main.c @@ -0,0 +1,135 @@ +/* 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(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 __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. */ +} diff --git a/libf2c/libF77/makefile.netlib b/libf2c/libF77/makefile.netlib new file mode 100644 index 00000000000..230ca7e9f93 --- /dev/null +++ b/libf2c/libF77/makefile.netlib @@ -0,0 +1,103 @@ +.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 +## Under Solaris (and other systems that do not understand ld -x), +## omit -x in the ld line above. +## If your system does not have the ld command, comment out +## or remove both the ld and mv lines above. + +MISC = F77_aloc.o 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 exit_.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 = F77_aloc.o s_cat.o s_cmp.o s_copy.o +F90BIT = lbitbits.o lbitshft.o +QINT = pow_qq.o qbitbits.o qbitshft.o +TIME = dtime_.o etime_.o + +all: signal1.h libF77.a + +# You may need to adjust signal1.h suitably for your system... +signal1.h: signal1.h0 + cp signal1.h0 signal1.h + +# If you get an error compiling dtime_.c or etime_.c, try adding +# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work, +# omit $(TIME) from the dependency list for libF77.a below. + +# For INTEGER*8 support (which requires system-dependent adjustments to +# f2c.h), add $(QINT) to the libf2c.a dependency list below... + +libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT) $(TIME) + ar r libF77.a $? + -ranlib libF77.a + +### If your system lacks ranlib, you don't need it; see README. + +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 + ranlib /usr/lib/libF77.a + +clean: + rm -f libF77.a *.o + +check: + xsum F77_aloc.c 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 dtime_.c \ + ef1asc_.c ef1cmc_.c erf_.c erfc_.c etime_.c exit_.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 lbitbits.c lbitshft.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 qbitbits.c qbitshft.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_cmp.c s_copy.c \ + s_paus.c s_rnge.c s_stop.c sig_die.c signal1.h0 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 diff --git a/libf2c/libF77/pow_ci.c b/libf2c/libF77/pow_ci.c new file mode 100644 index 00000000000..37e2ce0f2eb --- /dev/null +++ b/libf2c/libF77/pow_ci.c @@ -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; +} diff --git a/libf2c/libF77/pow_dd.c b/libf2c/libF77/pow_dd.c new file mode 100644 index 00000000000..d0dd0ff2744 --- /dev/null +++ b/libf2c/libF77/pow_dd.c @@ -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) ); +} diff --git a/libf2c/libF77/pow_di.c b/libf2c/libF77/pow_di.c new file mode 100644 index 00000000000..affed625a91 --- /dev/null +++ b/libf2c/libF77/pow_di.c @@ -0,0 +1,35 @@ +#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); +} diff --git a/libf2c/libF77/pow_hh.c b/libf2c/libF77/pow_hh.c new file mode 100644 index 00000000000..24a019734da --- /dev/null +++ b/libf2c/libF77/pow_hh.c @@ -0,0 +1,33 @@ +#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); + } diff --git a/libf2c/libF77/pow_ii.c b/libf2c/libF77/pow_ii.c new file mode 100644 index 00000000000..84d1c7e0b5e --- /dev/null +++ b/libf2c/libF77/pow_ii.c @@ -0,0 +1,33 @@ +#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); + } diff --git a/libf2c/libF77/pow_qq.c b/libf2c/libF77/pow_qq.c new file mode 100644 index 00000000000..3bc80e05f7f --- /dev/null +++ b/libf2c/libF77/pow_qq.c @@ -0,0 +1,33 @@ +#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); + } diff --git a/libf2c/libF77/pow_ri.c b/libf2c/libF77/pow_ri.c new file mode 100644 index 00000000000..6e5816bbf10 --- /dev/null +++ b/libf2c/libF77/pow_ri.c @@ -0,0 +1,35 @@ +#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); +} diff --git a/libf2c/libF77/pow_zi.c b/libf2c/libF77/pow_zi.c new file mode 100644 index 00000000000..898ea6be917 --- /dev/null +++ b/libf2c/libF77/pow_zi.c @@ -0,0 +1,61 @@ +#include "f2c.h" + +#ifdef KR_headers +VOID pow_zi(resx, a, b) /* p = a**b */ + doublecomplex *resx, *a; integer *b; +#else +extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); +void pow_zi(doublecomplex *resx, doublecomplex *a, integer *b) /* p = a**b */ +#endif +{ +integer n; +unsigned long u; +double t; +doublecomplex x; +doublecomplex res; +static doublecomplex one = {1.0, 0.0}; + +n = *b; + +if(n == 0) + { + resx->r = 1; + resx->i = 0; + return; + } + +res.r = 1; +res.i = 0; + +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 = res.r * x.r - res.i * x.i; + res.i = res.r * x.i + res.i * x.r; + res.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; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/pow_zz.c b/libf2c/libF77/pow_zz.c new file mode 100644 index 00000000000..20faf29cfb8 --- /dev/null +++ b/libf2c/libF77/pow_zz.c @@ -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); +} diff --git a/libf2c/libF77/qbitbits.c b/libf2c/libF77/qbitbits.c new file mode 100644 index 00000000000..ad4ac963ce2 --- /dev/null +++ b/libf2c/libF77/qbitbits.c @@ -0,0 +1,66 @@ +#include "f2c.h" + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + +#ifndef LONG8BITS +#define LONG8BITS (2*LONGBITS) +#endif + + integer +#ifdef KR_headers +qbit_bits(a, b, len) longint a; integer b, len; +#else +qbit_bits(longint a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + ulongint x, y; + + x = (ulongint) a; + y = (ulongint)-1L; + x >>= b; + y <<= len; + return (longint)(x & y); + } + + longint +#ifdef KR_headers +qbit_cshift(a, b, len) longint a; integer b, len; +#else +qbit_cshift(longint a, integer b, integer len) +#endif +{ + ulongint x, y, z; + + x = (ulongint)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONG8BITS) { + full_len: + if (b >= 0) { + b %= LONG8BITS; + return (longint)(x << b | x >> LONG8BITS - b ); + } + b = -b; + b %= LONG8BITS; + return (longint)(x << LONG8BITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (longint)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (longint)(y | z & (x >> b | x << len - b)); + } diff --git a/libf2c/libF77/qbitshft.c b/libf2c/libF77/qbitshft.c new file mode 100644 index 00000000000..87fffb91ff8 --- /dev/null +++ b/libf2c/libF77/qbitshft.c @@ -0,0 +1,11 @@ +#include "f2c.h" + + longint +#ifdef KR_headers +qbit_shift(a, b) longint a; integer b; +#else +qbit_shift(longint a, integer b) +#endif +{ + return b >= 0 ? a << b : (longint)((ulongint)a >> -b); + } diff --git a/libf2c/libF77/r_abs.c b/libf2c/libF77/r_abs.c new file mode 100644 index 00000000000..7b222961d16 --- /dev/null +++ b/libf2c/libF77/r_abs.c @@ -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); +} diff --git a/libf2c/libF77/r_acos.c b/libf2c/libF77/r_acos.c new file mode 100644 index 00000000000..330f88a3092 --- /dev/null +++ b/libf2c/libF77/r_acos.c @@ -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) ); +} diff --git a/libf2c/libF77/r_asin.c b/libf2c/libF77/r_asin.c new file mode 100644 index 00000000000..45ece4b749e --- /dev/null +++ b/libf2c/libF77/r_asin.c @@ -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) ); +} diff --git a/libf2c/libF77/r_atan.c b/libf2c/libF77/r_atan.c new file mode 100644 index 00000000000..36479c915b0 --- /dev/null +++ b/libf2c/libF77/r_atan.c @@ -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) ); +} diff --git a/libf2c/libF77/r_atn2.c b/libf2c/libF77/r_atn2.c new file mode 100644 index 00000000000..9347e1f13a9 --- /dev/null +++ b/libf2c/libF77/r_atn2.c @@ -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) ); +} diff --git a/libf2c/libF77/r_cnjg.c b/libf2c/libF77/r_cnjg.c new file mode 100644 index 00000000000..b6175eedfd7 --- /dev/null +++ b/libf2c/libF77/r_cnjg.c @@ -0,0 +1,16 @@ +#include "f2c.h" + +#ifdef KR_headers +VOID r_cnjg(resx, z) complex *resx, *z; +#else +VOID r_cnjg(complex *resx, complex *z) +#endif +{ +complex res; + +res.r = z->r; +res.i = - z->i; + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/r_cos.c b/libf2c/libF77/r_cos.c new file mode 100644 index 00000000000..5bda158cee9 --- /dev/null +++ b/libf2c/libF77/r_cos.c @@ -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) ); +} diff --git a/libf2c/libF77/r_cosh.c b/libf2c/libF77/r_cosh.c new file mode 100644 index 00000000000..7ae72cc0cef --- /dev/null +++ b/libf2c/libF77/r_cosh.c @@ -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) ); +} diff --git a/libf2c/libF77/r_dim.c b/libf2c/libF77/r_dim.c new file mode 100644 index 00000000000..baca95cd9e4 --- /dev/null +++ b/libf2c/libF77/r_dim.c @@ -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); +} diff --git a/libf2c/libF77/r_exp.c b/libf2c/libF77/r_exp.c new file mode 100644 index 00000000000..d1dea75563f --- /dev/null +++ b/libf2c/libF77/r_exp.c @@ -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) ); +} diff --git a/libf2c/libF77/r_imag.c b/libf2c/libF77/r_imag.c new file mode 100644 index 00000000000..d51252bbb79 --- /dev/null +++ b/libf2c/libF77/r_imag.c @@ -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); +} diff --git a/libf2c/libF77/r_int.c b/libf2c/libF77/r_int.c new file mode 100644 index 00000000000..8378e775726 --- /dev/null +++ b/libf2c/libF77/r_int.c @@ -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) ); +} diff --git a/libf2c/libF77/r_lg10.c b/libf2c/libF77/r_lg10.c new file mode 100644 index 00000000000..51f84201711 --- /dev/null +++ b/libf2c/libF77/r_lg10.c @@ -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) ); +} diff --git a/libf2c/libF77/r_log.c b/libf2c/libF77/r_log.c new file mode 100644 index 00000000000..4873fb418e8 --- /dev/null +++ b/libf2c/libF77/r_log.c @@ -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) ); +} diff --git a/libf2c/libF77/r_mod.c b/libf2c/libF77/r_mod.c new file mode 100644 index 00000000000..faea344a7b7 --- /dev/null +++ b/libf2c/libF77/r_mod.c @@ -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 +} diff --git a/libf2c/libF77/r_nint.c b/libf2c/libF77/r_nint.c new file mode 100644 index 00000000000..f5382af660a --- /dev/null +++ b/libf2c/libF77/r_nint.c @@ -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) ); +} diff --git a/libf2c/libF77/r_sign.c b/libf2c/libF77/r_sign.c new file mode 100644 index 00000000000..df6d02af00a --- /dev/null +++ b/libf2c/libF77/r_sign.c @@ -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); +} diff --git a/libf2c/libF77/r_sin.c b/libf2c/libF77/r_sin.c new file mode 100644 index 00000000000..095b9510de9 --- /dev/null +++ b/libf2c/libF77/r_sin.c @@ -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) ); +} diff --git a/libf2c/libF77/r_sinh.c b/libf2c/libF77/r_sinh.c new file mode 100644 index 00000000000..3bf4bb138be --- /dev/null +++ b/libf2c/libF77/r_sinh.c @@ -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) ); +} diff --git a/libf2c/libF77/r_sqrt.c b/libf2c/libF77/r_sqrt.c new file mode 100644 index 00000000000..d0203d3d19b --- /dev/null +++ b/libf2c/libF77/r_sqrt.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double r_sqrt(x) real *x; +#else +#undef abs +#include <math.h> +double r_sqrt(real *x) +#endif +{ +return( sqrt(*x) ); +} diff --git a/libf2c/libF77/r_tan.c b/libf2c/libF77/r_tan.c new file mode 100644 index 00000000000..fc0009e4774 --- /dev/null +++ b/libf2c/libF77/r_tan.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double r_tan(x) real *x; +#else +#undef abs +#include <math.h> +double r_tan(real *x) +#endif +{ +return( tan(*x) ); +} diff --git a/libf2c/libF77/r_tanh.c b/libf2c/libF77/r_tanh.c new file mode 100644 index 00000000000..818c6a8451b --- /dev/null +++ b/libf2c/libF77/r_tanh.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double r_tanh(x) real *x; +#else +#undef abs +#include <math.h> +double r_tanh(real *x) +#endif +{ +return( tanh(*x) ); +} diff --git a/libf2c/libF77/s_cat.c b/libf2c/libF77/s_cat.c new file mode 100644 index 00000000000..f462fd24945 --- /dev/null +++ b/libf2c/libF77/s_cat.c @@ -0,0 +1,75 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the + * target of a concatenation to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90). + */ + +#include "f2c.h" +#ifndef NO_OVERWRITE +#include <stdio.h> +#undef abs +#ifdef KR_headers + extern char *F77_aloc(); + extern void free(); + extern void G77_exit_0 (); +#else +#undef min +#undef max +#include <stdlib.h> + extern char *F77_aloc(ftnlen, char*); +#endif +#include <string.h> +#endif /* NO_OVERWRITE */ + + VOID +#ifdef KR_headers +s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnlen rnp[], *np, ll; +#else +s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll) +#endif +{ + ftnlen i, nc; + char *rp; + ftnlen n = *np; +#ifndef NO_OVERWRITE + ftnlen L, m; + char *lp0, *lp1; + + lp0 = 0; + lp1 = lp; + L = ll; + i = 0; + while(i < n) { + rp = rpp[i]; + m = rnp[i++]; + if (rp >= lp1 || rp + m <= lp) { + if ((L -= m) <= 0) { + n = i; + break; + } + lp1 += m; + continue; + } + lp0 = lp; + lp = lp1 = F77_aloc(L = ll, "s_cat"); + break; + } + lp1 = lp; +#endif /* NO_OVERWRITE */ + for(i = 0 ; i < n ; ++i) { + nc = ll; + if(rnp[i] < nc) + nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while(--nc >= 0) + *lp++ = *rp++; + } + while(--ll >= 0) + *lp++ = ' '; +#ifndef NO_OVERWRITE + if (lp0) { + memcpy(lp0, lp1, L); + free(lp1); + } +#endif + } diff --git a/libf2c/libF77/s_cmp.c b/libf2c/libF77/s_cmp.c new file mode 100644 index 00000000000..1e052f28642 --- /dev/null +++ b/libf2c/libF77/s_cmp.c @@ -0,0 +1,44 @@ +#include "f2c.h" + +/* compare two strings */ + +#ifdef KR_headers +integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; +#else +integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +#endif +{ +register unsigned char *a, *aend, *b, *bend; +a = (unsigned char *)a0; +b = (unsigned char *)b0; +aend = a + la; +bend = b + lb; + +if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + + while(b < bend) + if(*b != ' ') + return( ' ' - *b ); + else ++b; + } + +else + { + while(b < bend) + if(*a == *b) + { ++a; ++b; } + else + return( *a - *b ); + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else ++a; + } +return(0); +} diff --git a/libf2c/libF77/s_copy.c b/libf2c/libF77/s_copy.c new file mode 100644 index 00000000000..d1673510c62 --- /dev/null +++ b/libf2c/libF77/s_copy.c @@ -0,0 +1,51 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the + * target of an assignment to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90), + * as in a(2:5) = a(4:7) . + */ + +#include "f2c.h" + +/* assign strings: a = b */ + +#ifdef KR_headers +VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; +#else +void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +#endif +{ + register char *aend, *bend; + + aend = a + la; + + if(la <= lb) +#ifndef NO_OVERWRITE + if (a <= b || a >= b + la) +#endif + while(a < aend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else + for(b += la; a < aend; ) + *--aend = *--b; +#endif + + else { + bend = b + lb; +#ifndef NO_OVERWRITE + if (a <= b || a >= bend) +#endif + while(b < bend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else { + a += lb; + while(b < bend) + *--a = *--bend; + a += lb; + } +#endif + while(a < aend) + *a++ = ' '; + } + } diff --git a/libf2c/libF77/s_paus.c b/libf2c/libF77/s_paus.c new file mode 100644 index 00000000000..ee2a0ee6bf5 --- /dev/null +++ b/libf2c/libF77/s_paus.c @@ -0,0 +1,88 @@ +#include <stdio.h> +#include "f2c.h" +#define PAUSESIG 15 + +#ifdef KR_headers +#define Void /* void */ +#define Int /* int */ +#else +#define Void void +#define Int int +#undef abs +#undef min +#undef max +#include <stdlib.h> +#include "signal1.h" +#ifdef __cplusplus +extern "C" { +#endif +extern int getpid(void), isatty(int), pause(void); +#endif + +extern VOID f_exit(Void); + + static VOID +waitpause(Int n) +{ n = n; /* shut up compiler warning */ + return; + } + + static VOID +#ifdef KR_headers +s_1paus(fin) FILE *fin; +#else +s_1paus(FILE *fin) +#endif +{ + fprintf(stderr, + "To resume execution, type go. Other input will terminate the job.\n"); + fflush(stderr); + if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) { + fprintf(stderr, "STOP\n"); +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(0); + } + } + + int +#ifdef KR_headers +s_paus(s, n) char *s; ftnlen n; +#else +s_paus(char *s, ftnlen n) +#endif +{ + fprintf(stderr, "PAUSE "); + if(n > 0) + fprintf(stderr, " %.*s", (int)n, s); + fprintf(stderr, " statement executed\n"); + if( isatty(fileno(stdin)) ) + s_1paus(stdin); + else { +#if (defined (MSDOS) && !defined (GO32)) || defined (_WIN32) + FILE *fin; + fin = fopen("con", "r"); + if (!fin) { + fprintf(stderr, "s_paus: can't open con!\n"); + fflush(stderr); + exit(1); + } + s_1paus(fin); + fclose(fin); +#else + fprintf(stderr, + "To resume execution, execute a kill -%d %d command\n", + PAUSESIG, getpid() ); + signal1(PAUSESIG, waitpause); + fflush(stderr); + pause(); +#endif + } + fprintf(stderr, "Execution resumes after PAUSE.\n"); + fflush(stderr); + return 0; /* NOT REACHED */ +#ifdef __cplusplus + } +#endif +} diff --git a/libf2c/libF77/s_rnge.c b/libf2c/libF77/s_rnge.c new file mode 100644 index 00000000000..189b5247ced --- /dev/null +++ b/libf2c/libF77/s_rnge.c @@ -0,0 +1,26 @@ +#include <stdio.h> +#include "f2c.h" + +/* called when a subscript is out of range */ + +#ifdef KR_headers +extern VOID sig_die(); +integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; +#else +extern VOID sig_die(char*,int); +integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) +#endif +{ +register int i; + +fprintf(stderr, "Subscript out of range on file line %ld, procedure ", line); +while((i = *procn) && i != '_' && i != ' ') + putc(*procn++, stderr); +fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", offset+1); +while((i = *varn) && i != ' ') + putc(*varn++, stderr); +sig_die(".", 1); +#ifdef __cplusplus +return 0; +#endif +} diff --git a/libf2c/libF77/s_stop.c b/libf2c/libF77/s_stop.c new file mode 100644 index 00000000000..2e3f1035b30 --- /dev/null +++ b/libf2c/libF77/s_stop.c @@ -0,0 +1,37 @@ +#include <stdio.h> +#include "f2c.h" + +#ifdef KR_headers +extern void f_exit(); +VOID s_stop(s, n) char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include <stdlib.h> +#ifdef __cplusplus +extern "C" { +#endif +void f_exit(void); + +int s_stop(char *s, ftnlen n) +#endif +{ +int i; + +if(n > 0) + { + fprintf(stderr, "STOP "); + for(i = 0; i<n ; ++i) + putc(*s++, stderr); + fprintf(stderr, " statement executed\n"); + } +#ifdef NO_ONEXIT +f_exit(); +#endif +exit(0); +#ifdef __cplusplus +return 0; /* NOT REACHED */ +} +#endif +} diff --git a/libf2c/libF77/sig_die.c b/libf2c/libF77/sig_die.c new file mode 100644 index 00000000000..bebb1e7b8f7 --- /dev/null +++ b/libf2c/libF77/sig_die.c @@ -0,0 +1,45 @@ +#include <stdio.h> +#include <signal.h> + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifdef KR_headers +void sig_die(s, kill) register char *s; int kill; +#else +#include <stdlib.h> +#ifdef __cplusplus +extern "C" { +#endif + extern void f_exit(void); + +void sig_die(register char *s, int kill) +#endif +{ + /* print error message, then clear buffers */ + fprintf(stderr, "%s\n", s); + + if(kill) + { + fflush(stderr); + f_exit(); + fflush(stderr); + /* now get a core */ +#ifdef SIGIOT + signal(SIGIOT, SIG_DFL); +#endif + abort(); + } + else { +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(1); + } + } +#ifdef __cplusplus +} +#endif diff --git a/libf2c/libF77/signal1.h b/libf2c/libF77/signal1.h new file mode 100644 index 00000000000..b559211e8e4 --- /dev/null +++ b/libf2c/libF77/signal1.h @@ -0,0 +1,5 @@ +/* The g77 implementation of libf2c directly includes signal1.h0, + instead of copying it to signal1.h, since that seems easier to + cope with at this point. */ + +#include "signal1.h0" diff --git a/libf2c/libF77/signal1.h0 b/libf2c/libF77/signal1.h0 new file mode 100644 index 00000000000..8800a18d77b --- /dev/null +++ b/libf2c/libF77/signal1.h0 @@ -0,0 +1,25 @@ +/* You may need to adjust the definition of signal1 to supply a */ +/* cast to the correct argument type. This detail is system- and */ +/* compiler-dependent. The #define below assumes signal.h declares */ +/* type SIG_PF for the signal function's second argument. */ + +#include <signal.h> + +#ifndef Sigret_t +#define Sigret_t void +#endif +#ifndef Sigarg_t +#ifdef KR_headers +#define Sigarg_t +#else +#define Sigarg_t int +#endif +#endif /*Sigarg_t*/ + +#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +#define sig_pf SIG_PF +#else +typedef Sigret_t (*sig_pf)(Sigarg_t); +#endif + +#define signal1(a,b) signal(a,(sig_pf)b) diff --git a/libf2c/libF77/signal_.c b/libf2c/libF77/signal_.c new file mode 100644 index 00000000000..1ac81391aef --- /dev/null +++ b/libf2c/libF77/signal_.c @@ -0,0 +1,14 @@ +#include "f2c.h" +#include "signal1.h" + +#ifdef KR_headers +ftnint G77_signal_0 (sigp, proc) integer *sigp; sig_pf proc; +#else +ftnint G77_signal_0 (integer *sigp, sig_pf proc) +#endif +{ + int sig; + sig = (int)*sigp; + + return (ftnint)signal(sig, proc); + } diff --git a/libf2c/libF77/system_.c b/libf2c/libF77/system_.c new file mode 100644 index 00000000000..ed024a14ded --- /dev/null +++ b/libf2c/libF77/system_.c @@ -0,0 +1,36 @@ +/* f77 interface to system routine */ + +#include "f2c.h" + +#ifdef KR_headers +extern char *F77_aloc(); + + integer +G77_system_0 (s, n) register char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include <stdlib.h> +extern char *F77_aloc(ftnlen, char*); + + integer +G77_system_0 (register char *s, ftnlen n) +#endif +{ + char buff0[256], *buff; + register char *bp, *blast; + integer rv; + + buff = bp = n < sizeof(buff0) + ? buff0 : F77_aloc(n+1, "system_"); + blast = bp + n; + + while(bp < blast && *s) + *bp++ = *s++; + *bp = 0; + rv = system(buff); + if (buff != buff0) + free(buff); + return rv; + } diff --git a/libf2c/libF77/z_abs.c b/libf2c/libF77/z_abs.c new file mode 100644 index 00000000000..7e67ad2957f --- /dev/null +++ b/libf2c/libF77/z_abs.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double f__cabs(); +double z_abs(z) doublecomplex *z; +#else +double f__cabs(double, double); +double z_abs(doublecomplex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} diff --git a/libf2c/libF77/z_cos.c b/libf2c/libF77/z_cos.c new file mode 100644 index 00000000000..a811bbecc65 --- /dev/null +++ b/libf2c/libF77/z_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_cos(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include <math.h> +void z_cos(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.r = cos(z->r) * cosh(z->i); +res.i = - sin(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/z_div.c b/libf2c/libF77/z_div.c new file mode 100644 index 00000000000..4a987ab255a --- /dev/null +++ b/libf2c/libF77/z_div.c @@ -0,0 +1,39 @@ +#include "f2c.h" + +#ifdef KR_headers +extern VOID sig_die(); +VOID z_div(resx, a, b) doublecomplex *a, *b, *resx; +#else +extern void sig_die(char*, int); +void z_div(doublecomplex *resx, doublecomplex *a, doublecomplex *b) +#endif +{ +double ratio, den; +double abr, abi; +doublecomplex res; + +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 = b->r / b->i ; + den = b->i * (1 + ratio*ratio); + res.r = (a->r*ratio + a->i) / den; + res.i = (a->i*ratio - a->r) / den; + } + +else + { + ratio = b->i / b->r ; + den = b->r * (1 + ratio*ratio); + res.r = (a->r + a->i*ratio) / den; + res.i = (a->i - a->r*ratio) / den; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/z_exp.c b/libf2c/libF77/z_exp.c new file mode 100644 index 00000000000..85fb63e4209 --- /dev/null +++ b/libf2c/libF77/z_exp.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(), cos(), sin(); +VOID z_exp(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include <math.h> +void z_exp(doublecomplex *resx, doublecomplex *z) +#endif +{ +double expx; +doublecomplex res; + +expx = exp(z->r); +res.r = expx * cos(z->i); +res.i = expx * sin(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/z_log.c b/libf2c/libF77/z_log.c new file mode 100644 index 00000000000..48afca63d6d --- /dev/null +++ b/libf2c/libF77/z_log.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), f__cabs(), atan2(); +VOID z_log(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include <math.h> +extern double f__cabs(double, double); +void z_log(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.i = atan2(z->i, z->r); +res.r = log( f__cabs( z->r, z->i ) ); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/z_sin.c b/libf2c/libF77/z_sin.c new file mode 100644 index 00000000000..94456c9c30a --- /dev/null +++ b/libf2c/libF77/z_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_sin(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include <math.h> +void z_sin(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.r = sin(z->r) * cosh(z->i); +res.i = cos(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/libf2c/libF77/z_sqrt.c b/libf2c/libF77/z_sqrt.c new file mode 100644 index 00000000000..f5db5651991 --- /dev/null +++ b/libf2c/libF77/z_sqrt.c @@ -0,0 +1,33 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(), f__cabs(); +VOID z_sqrt(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include <math.h> +extern double f__cabs(double, double); +void z_sqrt(doublecomplex *resx, doublecomplex *z) +#endif +{ +double mag; +doublecomplex res; + +if( (mag = f__cabs(z->r, z->i)) == 0.) + res.r = res.i = 0.; +else if(z->r > 0) + { + res.r = sqrt(0.5 * (mag + z->r) ); + res.i = z->i / res.r / 2; + } +else + { + res.i = sqrt(0.5 * (mag - z->r) ); + if(z->i < 0) + res.i = - res.i; + res.r = z->i / res.i / 2; + } + +resx->r = res.r; +resx->i = res.i; +} |