libf2c2-20090411.orig/0002755000175000017500000000000011236400414012705 5ustar afrb2afrb2libf2c2-20090411.orig/Notice0000644000175000017500000000227411236375625014073 0ustar afrb2afrb2/**************************************************************** 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. ****************************************************************/ libf2c2-20090411.orig/README0000644000175000017500000004075411236375625013614 0ustar afrb2afrb2As shipped, "makefile" is a copy of "makefile.u", a Unix makefile. Variants for other systems have names of the form makefile.* and have initial comments saying how to invoke them. You may wish to copy one of the other makefile.* files to makefile. If you use a C++ compiler, first say make hadd to create a suitable f2c.h from f2c.h0 and f2ch.add. Otherwise, make f2c.h will just copy f2c.h0 to f2c.h . 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 . If your system lacks onexit() and you are not using an ANSI C compiler, then you should compile main.c with NO_ONEXIT defined. See the comments about onexit in makefile.u. 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. To check for transmission errors, issue the command make check or make -f makefile.u check This assumes you have the xsum program whose source, xsum.c, is distributed as part of "all from f2c/src", and that it is installed somewhere in your search path. 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 For convenience, the f2c.h0 in this directory is a copy of netlib's "f2c.h from f2c". It is best to install f2c.h in a standard place, so "include f2c.h" will work in any directory without further ado. Beware that the makefiles do not cause recompilation when f2c.h is changed. On machines, such as those using a DEC Alpha processor, on which sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by removing the first occurrence of "long " on each line containing "long ". On Unix systems, you can do this by issuing the commands mv f2c.h f2c.h0 sed 's/long int /int /' f2c.h0 >f2c.h On such machines, one can enable INTEGER*8 by uncommenting the typedefs of longint and ulongint in f2c.h and adjusting them, so they read typedef long longint; typedef unsigned long ulongint; and by compiling libf2c with -DAllow_TYQUAD, as discussed below. Most of the routines in libf2c 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. If you use the REAL valued functions listed below (ERF, ERFC, DTIME, and ETIME) with "f2c -R", then you need to compile the corresponding source files with -DREAL=float. To do this, it is perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile. 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 n occurs (on systems where this makes sense). If your compiler complains about the signal calls in main.c, s_paus.c, and signal_.c, you may need to adjust signal1.h suitably. See the comments in signal1.h. 8. ETIME(ARR) and DTIME(ARR) are REAL functions that return execution times. ARR is declared REAL ARR(2). The elapsed user and system CPU times are stored in ARR(1) and ARR(2), respectively. ETIME returns the total elapsed CPU time, i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU time since the previous call on DTIME. 9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes cmd to the system's command processor (on systems where this can be done). 10. CALL FLUSH flushes all buffers. 11. FTELL(i) is an INTEGER function that returns the current offset of Fortran unit i (or -1 if unit i is not open). 12. CALL FSEEK(i, offset, whence, *errlab) attemps to move Fortran unit i to the specified offset: absolute offset if whence = 0; relative to the current offset if whence = 1; relative to the end of the file if whence = 2. It branches to label errlab if unit i is not open or if the call otherwise fails. The routines whose objects are makefile.u's $(I77) are for I/O. The following comments apply to them. If your system lacks /usr/include/local.h , then you should create an appropriate local.h in this directory. An appropriate local.h may simply be empty, or it may #define VAX or #define CRAY (or whatever else you must do to make fp.h work right). Alternatively, edit fp.h to suite your machine. If your system lacks /usr/include/fcntl.h , then you should simply create an empty fcntl.h in this directory. If your compiler then complains about creat and open not having a prototype, compile with OPEN_DECL defined. On many systems, open and creat are declared in fcntl.h . If your system's sprintf does not work the way ANSI C specifies -- specifically, if it does not return the number of characters transmitted -- then insert the line #define USE_STRLEN at the end of fmt.h . This is necessary with at least some versions of Sun software. In particular, if you get a warning about an improper pointer/integer combination in compiling wref.c, then you need to compile with -DUSE_STRLEN . If your system's fopen does not like the ANSI binary reading and writing modes "rb" and "wb", then you should compile open.c with NON_ANSI_RW_MODES #defined. If you get error messages about references to cf->_ptr and cf->_base when compiling wrtfmt.c and wsfe.c or to stderr->_flag when compiling err.c, then insert the line #define NON_UNIX_STDIO at the beginning of fio.h, and recompile everything (or at least those modules that contain NON_UNIX_STDIO). Unformatted sequential records consist of a length of record contents, the record contents themselves, and the length of record contents again (for backspace). Prior to 17 Oct. 1991, the length was of type int; now it is of type long, but you can change it back to int by inserting #define UIOLEN_int at the beginning of fio.h. This affects only sue.c and uio.c . 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. On VAX, Cray, or Research Tenth-Edition Unix systems, you may need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS to make fp.h work correctly. Alternatively, you may need to edit fp.h to suit your machine. If your compiler complains about the signal calls in main.c, s_paus.c, and signal_.c, you may need to adjust signal1.h suitably. See the comments in signal1.h. You may need to supply the following non-ANSI routines: fstat(int fileds, struct stat *buf) is similar to stat(char *name, struct stat *buf), except that the first argument, fileds, is the file descriptor returned by open rather than the name of the file. fstat is used in the system-dependent routine canseek (in the libf2c source file err.c), which is supposed to return 1 if it's possible to issue seeks on the file in question, 0 if it's not; you may need to suitably modify err.c . On non-UNIX systems, you can avoid references to fstat and stat by compiling with NON_UNIX_STDIO defined; in that case, you may need to supply access(char *Name,0), which is supposed to return 0 if file Name exists, nonzero otherwise. char * mktemp(char *buf) is supposed to replace the 6 trailing X's in buf with a unique number and then return buf. The idea is to get a unique name for a temporary file. On non-UNIX systems, you may need to change a few other, e.g.: the form of name computed by mktemp() in endfile.c and open.c; the use of the open(), close(), and creat() system calls in endfile.c, err.c, open.c; and the modes in calls on fopen() and fdopen() (and perhaps the use of fdopen() itself -- it's supposed to return a FILE* corresponding to a given an integer file descriptor) in err.c and open.c (component ufmt of struct unit is 1 for formatted I/O -- text mode on some systems -- and 0 for unformatted I/O -- binary mode on some systems). Compiling with -DNON_UNIX_STDIO omits all references to creat() and almost all references to open() and close(), the exception being in the function f__isdev() (in open.c). If you wish to use translated Fortran that has funny notions of record length for direct unformatted I/O (i.e., that assumes RECL= values in OPEN statements are not bytes but rather counts of some other units -- e.g., 4-character words for VMS), then you should insert an appropriate #define for url_Adjust at the beginning of open.c . For VMS Fortran, for example, #define url_Adjust(x) x *= 4 would suffice. By default, Fortran I/O units 5, 6, and 0 are pre-connected to stdin, stdout, and stderr, respectively. You can change this behavior by changing f_init() in err.c to suit your needs. Note that f2c assumes READ(*... means READ(5... and WRITE(*... means WRITE(6... . Moreover, an OPEN(n,... statement that does not specify a file name (and does not specify STATUS='SCRATCH') assumes FILE='fort.n' . You can change this by editing open.c and endfile.c suitably. Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units 0, 1, ..., 99 are available, i.e., the highest allowed unit number is MXUNIT - 1. Lines protected from compilation by #ifdef Allow_TYQUAD are for a possible extension to 64-bit integers in which integer = int = 32 bits and longint = long = 64 bits. 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 $(QINT) to the end of the makefile's dependency list for libf2c.a (if makefile is a copy of makefile.u; for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj to the library's dependency list and adjust libf2c.lbc or libf2c.sy accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS assignment. To make longint and ulongint available, it may suffice to add -DINTEGER_STAR_8 to the CFLAGS assignment. 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 . Extensions (Feb. 1993) to NAMELIST processing: 1. Reading a ? instead of &name (the start of a namelist) causes the namelist being sought to be written to stdout (unit 6); to omit this feature, compile rsne.c with -DNo_Namelist_Questions. 2. Reading the wrong namelist name now leads to an error message and an attempt to skip input until the right namelist name is found; to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. 3. Namelist writes now insert newlines before each variable; to omit this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. 4. (Sept. 1995) When looking for the &name that starts namelist input, lines whose first non-blank character is something other than &, $, or ? are treated as comment lines and ignored, unless rsne.c is compiled with -DNo_Namelist_Comments. Nonstandard extension (Feb. 1993) to open: for sequential files, ACCESS='APPEND' (or access='anything else starting with "A" or "a"') causes the file to be positioned at end-of-file, so a write will append to the file. Some buggy Fortran programs use unformatted direct I/O to write an incomplete record and later read more from that record than they have written. For records other than the last, the unwritten portion of the record reads as binary zeros. The last record is a special case: attempting to read more from it than was written gives end-of-file -- which may help one find a bug. Some other Fortran I/O libraries treat the last record no differently than others and thus give no help in finding the bug of reading more than was written. If you wish to have this behavior, compile uio.c with -DPad_UDread . If you want to be able to catch write failures (e.g., due to a disk being full) with an ERR= specifier, compile dfe.c, due.c, sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to slower execution and more I/O, but should make ERR= work as expected, provided fflush returns an error return when its physical write fails. Carriage controls are meant to be interpreted by the UNIX col program (or a similar program). Sometimes it's convenient to use only ' ' as the carriage control character (normal single spacing). If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted external output lines will have an initial ' ' quietly omitted, making use of the col program unnecessary with output that only has ' ' for carriage control. The Fortran 77 Standard leaves it up to the implementation whether formatted writes of floating-point numbers of absolute value < 1 have a zero before the decimal point. By default, libI77 omits such superfluous zeros, but you can cause them to appear by compiling lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . If your (Unix) 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 By default, the routines that implement complex and double complex division, c_div.c and z_div.c, call sig_die to print an error message and exit if they see a divisor of 0, as this is sometimes helpful for debugging. On systems with IEEE arithmetic, compiling c_div.c and z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both the real and imaginary parts of the result to +INFINITY if the numerator is nonzero, or to NaN if it vanishes. Nowadays most Unix and Linux systems have function int ftruncate(int fildes, off_t len); defined in system header file unistd.h that adjusts the length of file descriptor fildes to length len. Unless endfile.c is compiled with -DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if necessary to shorten files. If your system lacks ftruncate(), compile endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more portable scheme of shortening a file by copying to a temporary file and back again. The initializations for "f2c -trapuv" are done by _uninit_f2c(), whose source is uninit.c, introduced June 2001. On IEEE-arithmetic systems, _uninit_f2c should initialize floating-point variables to signaling NaNs and, at its first invocation, should enable the invalid operation exception. Alas, the rules for distinguishing signaling from quiet NaNs were not specified in the IEEE P754 standard, nor were the precise means of enabling and disabling IEEE-arithmetic exceptions, and these details are thus system dependent. There are #ifdef's in uninit.c that specify them for some popular systems. If yours is not one of these systems, it may take some detective work to discover the appropriate details for your system. Sometimes it helps to look in the standard include directories for header files with relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and it may be simplest to run experiments to see what distinguishes a signaling from a quiet NaN. (If x is initialized to a signaling NaN and the invalid operation exception is masked off, as it should be by default on IEEE-arithmetic systems, then computing, say, y = x + 1 will yield a quiet NaN.) libf2c2-20090411.orig/abort_.c0000644000175000017500000000046011236375625014334 0ustar afrb2afrb2#include "stdio.h" #include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers extern VOID sig_die(); int abort_() #else extern void sig_die(const char*,int); int abort_(void) #endif { sig_die("Fortran abort routine called", 1); return 0; /* not reached */ } #ifdef __cplusplus } #endif libf2c2-20090411.orig/arithchk.c0000644000175000017500000001206311236375625014665 0ustar afrb2afrb2/**************************************************************** Copyright (C) 1997, 1998, 2000 Lucent Technologies All Rights Reserved Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the name of Lucent or any of its entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ****************************************************************/ /* Try to deduce arith.h from arithmetic properties. */ #include #include #include #ifdef NO_FPINIT #define fpinit_ASL() #else #ifndef KR_headers extern #ifdef __cplusplus "C" #endif void fpinit_ASL(void); #endif /*KR_headers*/ #endif /*NO_FPINIT*/ static int dalign; typedef struct Akind { char *name; int kind; } Akind; static Akind IEEE_8087 = { "IEEE_8087", 1 }, IEEE_MC68k = { "IEEE_MC68k", 2 }, IBM = { "IBM", 3 }, VAX = { "VAX", 4 }, CRAY = { "CRAY", 5}; static double t_nan; static Akind * Lcheck(void) { union { double d; long L[2]; } u; struct { double d; long L; } x[2]; if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) dalign = 1; u.L[0] = u.L[1] = 0; u.d = 1e13; if (u.L[0] == 1117925532 && u.L[1] == -448790528) return &IEEE_MC68k; if (u.L[1] == 1117925532 && u.L[0] == -448790528) return &IEEE_8087; if (u.L[0] == -2065213935 && u.L[1] == 10752) return &VAX; if (u.L[0] == 1267827943 && u.L[1] == 704643072) return &IBM; return 0; } static Akind * icheck(void) { union { double d; int L[2]; } u; struct { double d; int L; } x[2]; if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) dalign = 1; u.L[0] = u.L[1] = 0; u.d = 1e13; if (u.L[0] == 1117925532 && u.L[1] == -448790528) return &IEEE_MC68k; if (u.L[1] == 1117925532 && u.L[0] == -448790528) return &IEEE_8087; if (u.L[0] == -2065213935 && u.L[1] == 10752) return &VAX; if (u.L[0] == 1267827943 && u.L[1] == 704643072) return &IBM; return 0; } char *emptyfmt = ""; /* avoid possible warning message with printf("") */ static Akind * ccheck(void) { union { double d; long L; } u; long Cray1; /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; if (printf(emptyfmt, Cray1) >= 0) Cray1 = 1000000*Cray1 + 693716; if (printf(emptyfmt, Cray1) >= 0) Cray1 = 1000000*Cray1 + 115456; u.d = 1e13; if (u.L == Cray1) return &CRAY; return 0; } static int fzcheck(void) { double a, b; int i; a = 1.; b = .1; for(i = 155;; b *= b, i >>= 1) { if (i & 1) { a *= b; if (i == 1) break; } } b = a * a; return b == 0.; } static int need_nancheck(void) { double t; errno = 0; t = log(t_nan); if (errno == 0) return 1; errno = 0; t = sqrt(t_nan); return errno == 0; } void get_nanbits(unsigned int *b, int k) { union { double d; unsigned int z[2]; } u, u1, u2; k = 2 - k; u1.z[k] = u2.z[k] = 0x7ff00000; u1.z[1-k] = u2.z[1-k] = 0; u.d = u1.d - u2.d; /* Infinity - Infinity */ b[0] = u.z[0]; b[1] = u.z[1]; } int main(void) { FILE *f; Akind *a = 0; int Ldef = 0; unsigned int nanbits[2]; fpinit_ASL(); #ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ f = fopen("arith.h", "w"); if (!f) { printf("Cannot open arith.h\n"); return 1; } #else f = stdout; #endif if (sizeof(double) == 2*sizeof(long)) a = Lcheck(); else if (sizeof(double) == 2*sizeof(int)) { Ldef = 1; a = icheck(); } else if (sizeof(double) == sizeof(long)) a = ccheck(); if (a) { fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", a->name, a->kind); if (Ldef) fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); if (dalign) fprintf(f, "#define Double_Align\n"); if (sizeof(char*) == 8) fprintf(f, "#define X64_bit_pointers\n"); #ifndef NO_LONG_LONG if (sizeof(long long) < 8) #endif fprintf(f, "#define NO_LONG_LONG\n"); if (a->kind <= 2) { if (fzcheck()) fprintf(f, "#define Sudden_Underflow\n"); t_nan = -a->kind; if (need_nancheck()) fprintf(f, "#define NANCHECK\n"); if (sizeof(double) == 2*sizeof(unsigned int)) { get_nanbits(nanbits, a->kind); fprintf(f, "#define QNaN0 0x%x\n", nanbits[0]); fprintf(f, "#define QNaN1 0x%x\n", nanbits[1]); } } return 0; } fprintf(f, "/* Unknown arithmetic */\n"); return 1; } #ifdef __sun #ifdef __i386 /* kludge for Intel Solaris */ void fpsetprec(int x) { } #endif #endif libf2c2-20090411.orig/backspac.c0000644000175000017500000000246011236375625014637 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers integer f_back(a) alist *a; #else integer f_back(alist *a) #endif { unit *b; OFF_T v, w, x, y, z; uiolen n; FILE *f; f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ if(a->aunit >= MXUNIT || a->aunit < 0) err(a->aerr,101,"backspace") if(b->useek==0) err(a->aerr,106,"backspace") if(b->ufd == NULL) { fk_open(1, 1, a->aunit); return(0); } if(b->uend==1) { b->uend=0; return(0); } if(b->uwrt) { t_runc(a); if (f__nowreading(b)) err(a->aerr,errno,"backspace") } f = b->ufd; /* may have changed in t_runc() */ if(b->url>0) { x=FTELL(f); y = x % b->url; if(y == 0) x--; x /= b->url; x *= b->url; (void) FSEEK(f,x,SEEK_SET); return(0); } if(b->ufmt==0) { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); fread((char *)&n,sizeof(uiolen),1,f); FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); return(0); } w = x = FTELL(f); z = 0; loop: while(x) { x -= x < 64 ? x : 64; FSEEK(f,x,SEEK_SET); for(y = x; y < w; y++) { if (getc(f) != '\n') continue; v = FTELL(f); if (v == w) { if (z) goto break2; goto loop; } z = v; } err(a->aerr,(EOF),"backspace") } break2: FSEEK(f, z, SEEK_SET); return 0; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/c_abs.c0000644000175000017500000000042011236375625014131 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers extern double f__cabs(); double c_abs(z) complex *z; #else extern double f__cabs(double, double); double c_abs(complex *z) #endif { return( f__cabs( z->r, z->i ) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/c_cos.c0000644000175000017500000000054211236375625014155 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers extern double sin(), cos(), sinh(), cosh(); VOID c_cos(r, z) complex *r, *z; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif void c_cos(complex *r, complex *z) #endif { double zi = z->i, zr = z->r; r->r = cos(zr) * cosh(zi); r->i = - sin(zr) * sinh(zi); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/c_div.c0000644000175000017500000000165011236375625014154 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers extern VOID sig_die(); VOID c_div(c, a, b) complex *a, *b, *c; #else extern void sig_die(const char*,int); void c_div(complex *c, complex *a, complex *b) #endif { double ratio, den; double abr, abi, cr; if( (abr = b->r) < 0.) abr = - abr; if( (abi = b->i) < 0.) abi = - abi; if( abr <= abi ) { if(abi == 0) { #ifdef IEEE_COMPLEX_DIVIDE float af, bf; af = bf = abr; if (a->i != 0 || a->r != 0) af = 1.; c->i = c->r = af / bf; return; #else sig_die("complex division by zero", 1); #endif } ratio = (double)b->r / b->i ; den = b->i * (1 + ratio*ratio); cr = (a->r*ratio + a->i) / den; c->i = (a->i*ratio - a->r) / den; } else { ratio = (double)b->i / b->r ; den = b->r * (1 + ratio*ratio); cr = (a->r + a->i*ratio) / den; c->i = (a->i - a->r*ratio) / den; } c->r = cr; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/c_exp.c0000644000175000017500000000053511236375625014167 0ustar afrb2afrb2#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" #ifdef __cplusplus extern "C" { #endif void c_exp(complex *r, complex *z) #endif { double expx, zi = z->i; expx = exp(z->r); r->r = expx * cos(zi); r->i = expx * sin(zi); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/c_log.c0000644000175000017500000000060011236375625014145 0ustar afrb2afrb2#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" #ifdef __cplusplus extern "C" { #endif extern double f__cabs(double, double); void c_log(complex *r, complex *z) #endif { double zi, zr; r->i = atan2(zi = z->i, zr = z->r); r->r = log( f__cabs(zr, zi) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/c_sin.c0000644000175000017500000000053611236375625014165 0ustar afrb2afrb2#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" #ifdef __cplusplus extern "C" { #endif void c_sin(complex *r, complex *z) #endif { double zi = z->i, zr = z->r; r->r = sin(zr) * cosh(zi); r->i = cos(zr) * sinh(zi); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/c_sqrt.c0000644000175000017500000000113511236375625014361 0ustar afrb2afrb2#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" #ifdef __cplusplus extern "C" { #endif extern double f__cabs(double, double); void c_sqrt(complex *r, complex *z) #endif { double mag, t; double zi = z->i, zr = z->r; if( (mag = f__cabs(zr, zi)) == 0.) r->r = r->i = 0.; else if(zr > 0) { r->r = t = sqrt(0.5 * (mag + zr) ); t = zi / t; r->i = 0.5 * t; } else { t = sqrt(0.5 * (mag - zr) ); if(zi < 0) t = -t; r->i = t; t = zi / t; r->r = 0.5 * t; } } #ifdef __cplusplus } #endif libf2c2-20090411.orig/cabs.c0000644000175000017500000000075611236375625014006 0ustar afrb2afrb2#ifdef KR_headers extern double sqrt(); double f__cabs(real, imag) double real, imag; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif 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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/close.c0000644000175000017500000000256111236375625014177 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef KR_headers integer f_clos(a) cllist *a; #else #undef abs #undef min #undef max #include "stdlib.h" #ifdef NON_UNIX_STDIO #ifndef unlink #define unlink remove #endif #else #ifdef MSDOS #include "io.h" #else #ifdef __cplusplus extern "C" int unlink(const char*); #else extern int unlink(const char*); #endif #endif #endif #ifdef __cplusplus extern "C" { #endif integer f_clos(cllist *a) #endif { unit *b; if(a->cunit >= MXUNIT) return(0); b= &f__units[a->cunit]; if(b->ufd==NULL) goto done; if (b->uscrtch == 1) goto Delete; if (!a->csta) goto Keep; switch(*a->csta) { default: Keep: case 'k': case 'K': if(b->uwrt == 1) t_runc((alist *)a); if(b->ufnm) { fclose(b->ufd); free(b->ufnm); } break; case 'd': case 'D': Delete: fclose(b->ufd); if(b->ufnm) { unlink(b->ufnm); /*SYSDEP*/ free(b->ufnm); } } b->ufd=NULL; done: b->uend=0; b->ufnm=NULL; return(0); } void #ifdef KR_headers f_exit() #else f_exit(void) #endif { int i; static cllist xx; if (!xx.cerr) { xx.cerr=1; xx.csta=NULL; for(i=0;i #else /*{*/ #ifndef My_ctype_DEF extern char My_ctype[]; #else /*{*/ char My_ctype[264] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; #endif /*}*/ #define isdigit(x) (My_ctype[(x)+8] & 1) #define isspace(x) (My_ctype[(x)+8] & 2) #endif libf2c2-20090411.orig/d_abs.c0000644000175000017500000000033211236375625014134 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers double d_abs(x) doublereal *x; #else double d_abs(doublereal *x) #endif { if(*x >= 0) return(*x); return(- *x); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_acos.c0000644000175000017500000000036511236375625014322 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double acos(); double d_acos(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_acos(doublereal *x) #endif { return( acos(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_asin.c0000644000175000017500000000036511236375625014327 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double asin(); double d_asin(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_asin(doublereal *x) #endif { return( asin(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_atan.c0000644000175000017500000000036511236375625014320 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double atan(); double d_atan(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_atan(doublereal *x) #endif { return( atan(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_atn2.c0000644000175000017500000000041711236375625014237 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double atan2(); double d_atn2(x,y) doublereal *x, *y; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_atn2(doublereal *x, doublereal *y) #endif { return( atan2(*x,*y) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_cnjg.c0000644000175000017500000000037711236375625014321 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif VOID #ifdef KR_headers d_cnjg(r, z) doublecomplex *r, *z; #else d_cnjg(doublecomplex *r, doublecomplex *z) #endif { doublereal zi = z->i; r->r = z->r; r->i = -zi; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_cos.c0000644000175000017500000000036111236375625014155 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double cos(); double d_cos(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_cos(doublereal *x) #endif { return( cos(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_cosh.c0000644000175000017500000000036511236375625014331 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double cosh(); double d_cosh(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_cosh(doublereal *x) #endif { return( cosh(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_dim.c0000644000175000017500000000035011236375625014140 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_exp.c0000644000175000017500000000036111236375625014165 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double exp(); double d_exp(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_exp(doublereal *x) #endif { return( exp(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_imag.c0000644000175000017500000000031111236375625014301 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers double d_imag(z) doublecomplex *z; #else double d_imag(doublecomplex *z) #endif { return(z->i); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_int.c0000644000175000017500000000041511236375625014163 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); double d_int(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_int(doublereal *x) #endif { return( (*x>0) ? floor(*x) : -floor(- *x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_lg10.c0000644000175000017500000000044311236375625014135 0ustar afrb2afrb2#include "f2c.h" #define log10e 0.43429448190325182765 #ifdef KR_headers double log(); double d_lg10(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_lg10(doublereal *x) #endif { return( log10e * log(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_log.c0000644000175000017500000000036111236375625014152 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double log(); double d_log(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_log(doublereal *x) #endif { return( log(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_mod.c0000644000175000017500000000126011236375625014147 0ustar afrb2afrb2#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" #ifdef __cplusplus extern "C" { #endif #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 } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_nint.c0000644000175000017500000000043111236375625014337 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); double d_nint(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_nint(doublereal *x) #endif { return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_prod.c0000644000175000017500000000031711236375625014336 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers double d_prod(x,y) real *x, *y; #else double d_prod(real *x, real *y) #endif { return( (*x) * (*y) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_sign.c0000644000175000017500000000041211236375625014326 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_sin.c0000644000175000017500000000036111236375625014162 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sin(); double d_sin(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_sin(doublereal *x) #endif { return( sin(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_sinh.c0000644000175000017500000000036511236375625014336 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sinh(); double d_sinh(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_sinh(doublereal *x) #endif { return( sinh(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_sqrt.c0000644000175000017500000000036511236375625014366 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sqrt(); double d_sqrt(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_sqrt(doublereal *x) #endif { return( sqrt(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_tan.c0000644000175000017500000000036111236375625014153 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double tan(); double d_tan(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_tan(doublereal *x) #endif { return( tan(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/d_tanh.c0000644000175000017500000000036511236375625014327 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double tanh(); double d_tanh(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double d_tanh(doublereal *x) #endif { return( tanh(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/derf_.c0000644000175000017500000000035711236375625014152 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers double erf(); double derf_(x) doublereal *x; #else extern double erf(double); double derf_(doublereal *x) #endif { return( erf(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/derfc_.c0000644000175000017500000000037511236375625014315 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers extern double erfc(); double derfc_(x) doublereal *x; #else extern double erfc(double); double derfc_(doublereal *x) #endif { return( erfc(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/dfe.c0000644000175000017500000000510011236375625013620 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "fmt.h" #ifdef __cplusplus extern "C" { #endif int y_rsk(Void) { if(f__curunit->uend || f__curunit->url <= f__recpos || f__curunit->url == 1) return 0; do { getc(f__cf); } while(++f__recpos < f__curunit->url); return 0; } int y_getc(Void) { int ch; if(f__curunit->uend) return(-1); if((ch=getc(f__cf))!=EOF) { f__recpos++; if(f__curunit->url>=f__recpos || f__curunit->url==1) return(ch); else return(' '); } if(feof(f__cf)) { f__curunit->uend=1; errno=0; return(-1); } err(f__elist->cierr,errno,"readingd"); } static int y_rev(Void) { if (f__recpos < f__hiwater) f__recpos = f__hiwater; if (f__curunit->url > 1) while(f__recpos < f__curunit->url) (*f__putn)(' '); if (f__recpos) f__putbuf(0); f__recpos = 0; return(0); } static int y_err(Void) { err(f__elist->cierr, 110, "dfe"); } static int y_newrec(Void) { y_rev(); f__hiwater = f__cursor = 0; return(1); } int #ifdef KR_headers c_dfe(a) cilist *a; #else c_dfe(cilist *a) #endif { f__sequential=0; f__formatted=f__external=1; f__elist=a; f__cursor=f__scale=f__recpos=0; f__curunit = &f__units[a->ciunit]; if(a->ciunit>MXUNIT || a->ciunit<0) err(a->cierr,101,"startchk"); if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) err(a->cierr,104,"dfe"); f__cf=f__curunit->ufd; if(!f__curunit->ufmt) err(a->cierr,102,"dfe") if(!f__curunit->useek) err(a->cierr,104,"dfe") f__fmtbuf=a->cifmt; if(a->cirec <= 0) err(a->cierr,130,"dfe") FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET); f__curunit->uend = 0; return(0); } #ifdef KR_headers integer s_rdfe(a) cilist *a; #else integer s_rdfe(cilist *a) #endif { int n; if(!f__init) f_init(); f__reading=1; if(n=c_dfe(a))return(n); if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr,errno,"read start"); f__getn = y_getc; f__doed = rd_ed; f__doned = rd_ned; f__dorevert = f__donewrec = y_err; f__doend = y_rsk; if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"read start"); fmt_bg(); return(0); } #ifdef KR_headers integer s_wdfe(a) cilist *a; #else integer s_wdfe(cilist *a) #endif { int n; if(!f__init) f_init(); f__reading=0; if(n=c_dfe(a)) return(n); if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) err(a->cierr,errno,"startwrt"); f__putn = x_putc; f__doed = w_ed; f__doned= w_ned; f__dorevert = y_err; f__donewrec = y_newrec; f__doend = y_rev; if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startwrt"); fmt_bg(); return(0); } integer e_rdfe(Void) { en_fio(); return 0; } integer e_wdfe(Void) { return en_fio(); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/dolio.c0000644000175000017500000000072711236375625014202 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers extern int (*f__lioproc)(); integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; #else extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) #endif { return((*f__lioproc)(number,ptr,len,*type)); } #ifdef __cplusplus } #endif #ifdef __cplusplus } #endif libf2c2-20090411.orig/dtime_.c0000644000175000017500000000171411236375625014332 0ustar afrb2afrb2#include "time.h" #ifdef MSDOS #undef USE_CLOCK #define USE_CLOCK #endif #ifndef REAL #define REAL double #endif #ifndef USE_CLOCK #define _INCLUDE_POSIX_SOURCE /* for HP-UX */ #define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ #include "sys/types.h" #include "sys/times.h" #ifdef __cplusplus extern "C" { #endif #endif #undef Hz #ifdef CLK_TCK #define Hz CLK_TCK #else #ifdef HZ #define Hz HZ #else #define Hz 60 #endif #endif REAL #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] = (double)(t.tms_utime - t0.tms_utime) / Hz; tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz; t0 = t; return tarray[0] + tarray[1]; #endif } #ifdef __cplusplus } #endif libf2c2-20090411.orig/due.c0000644000175000017500000000313011236375625013640 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif int #ifdef KR_headers c_due(a) cilist *a; #else c_due(cilist *a) #endif { if(!f__init) f_init(); f__sequential=f__formatted=f__recpos=0; f__external=1; f__curunit = &f__units[a->ciunit]; if(a->ciunit>=MXUNIT || a->ciunit<0) err(a->cierr,101,"startio"); f__elist=a; if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); f__cf=f__curunit->ufd; if(f__curunit->ufmt) err(a->cierr,102,"cdue") if(!f__curunit->useek) err(a->cierr,104,"cdue") if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue") if(a->cirec <= 0) err(a->cierr,130,"due") FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET); f__curunit->uend = 0; return(0); } #ifdef KR_headers integer s_rdue(a) cilist *a; #else integer s_rdue(cilist *a) #endif { int n; f__reading=1; if(n=c_due(a)) return(n); if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr,errno,"read start"); return(0); } #ifdef KR_headers integer s_wdue(a) cilist *a; #else integer s_wdue(cilist *a) #endif { int n; f__reading=0; if(n=c_due(a)) return(n); if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) err(a->cierr,errno,"write start"); return(0); } integer e_rdue(Void) { if(f__curunit->url==1 || f__recpos==f__curunit->url) return(0); FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR); if(FTELL(f__cf)%f__curunit->url) err(f__elist->cierr,200,"syserr"); return(0); } integer e_wdue(Void) { #ifdef ALWAYS_FLUSH if (fflush(f__cf)) err(f__elist->cierr,errno,"write end"); #endif return(e_rdue()); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/ef1asc_.c0000644000175000017500000000101111236375625014360 0ustar afrb2afrb2/* EFL support routine to copy string b to string a */ #include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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 ); return 0; /* ignored return value */ } #ifdef __cplusplus } #endif libf2c2-20090411.orig/ef1cmc_.c0000644000175000017500000000065311236375625014367 0ustar afrb2afrb2/* EFL support routine to compare two character strings */ #include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/endfile.c0000644000175000017500000000542611236375625014503 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" /* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */ /* if it does not define int truncate(const char *name, off_t). */ #ifdef MSDOS #undef NO_TRUNCATE #define NO_TRUNCATE #endif #ifndef NO_TRUNCATE #include "unistd.h" #endif #ifdef KR_headers extern char *strcpy(); extern FILE *tmpfile(); #else #undef abs #undef min #undef max #include "stdlib.h" #include "string.h" #ifdef __cplusplus extern "C" { #endif #endif extern char *f__r_mode[], *f__w_mode[]; #ifdef KR_headers integer f_end(a) alist *a; #else integer f_end(alist *a) #endif { unit *b; FILE *tf; if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); b = &f__units[a->aunit]; if(b->ufd==NULL) { char nbuf[10]; sprintf(nbuf,"fort.%ld",(long)a->aunit); if (tf = FOPEN(nbuf, f__w_mode[0])) fclose(tf); return(0); } b->uend=1; return(b->useek ? t_runc(a) : 0); } #ifdef NO_TRUNCATE static int #ifdef KR_headers copy(from, len, to) FILE *from, *to; register long len; #else copy(FILE *from, register long len, FILE *to) #endif { int len1; char buf[BUFSIZ]; while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { if (!fwrite(buf, len1, 1, to)) return 1; if ((len -= len1) <= 0) break; } return 0; } #endif /* NO_TRUNCATE */ int #ifdef KR_headers t_runc(a) alist *a; #else t_runc(alist *a) #endif { OFF_T loc, len; unit *b; int rc; FILE *bf; #ifdef NO_TRUNCATE FILE *tf; #endif b = &f__units[a->aunit]; if(b->url) return(0); /*don't truncate direct files*/ loc=FTELL(bf = b->ufd); FSEEK(bf,(OFF_T)0,SEEK_END); len=FTELL(bf); if (loc >= len || b->useek == 0) return(0); #ifdef NO_TRUNCATE if (b->ufnm == NULL) return 0; rc = 0; fclose(b->ufd); if (!loc) { if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt]))) rc = 1; if (b->uwrt) b->uwrt = 1; goto done; } if (!(bf = FOPEN(b->ufnm, f__r_mode[0])) || !(tf = tmpfile())) { #ifdef NON_UNIX_STDIO bad: #endif rc = 1; goto done; } if (copy(bf, (long)loc, tf)) { bad1: rc = 1; goto done1; } if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf))) goto bad1; rewind(tf); if (copy(tf, (long)loc, bf)) goto bad1; b->uwrt = 1; b->urw = 2; #ifdef NON_UNIX_STDIO if (b->ufmt) { fclose(bf); if (!(bf = FOPEN(b->ufnm, f__w_mode[3]))) goto bad; FSEEK(bf,(OFF_T)0,SEEK_END); b->urw = 3; } #endif done1: fclose(tf); done: f__cf = b->ufd = bf; #else /* NO_TRUNCATE */ if (b->urw & 2) fflush(b->ufd); /* necessary on some Linux systems */ #ifndef FTRUNCATE #define FTRUNCATE ftruncate #endif rc = FTRUNCATE(fileno(b->ufd), loc); /* The following FSEEK is unnecessary on some systems, */ /* but should be harmless. */ FSEEK(b->ufd, (OFF_T)0, SEEK_END); #endif /* NO_TRUNCATE */ if (rc) err(a->aerr,111,"endfile"); return 0; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/erf_.c0000644000175000017500000000041611236375625014002 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifndef REAL #define REAL double #endif #ifdef KR_headers double erf(); REAL erf_(x) real *x; #else extern double erf(double); REAL erf_(real *x) #endif { return( erf((double)*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/erfc_.c0000644000175000017500000000042311236375625014143 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifndef REAL #define REAL double #endif #ifdef KR_headers double erfc(); REAL erfc_(x) real *x; #else extern double erfc(double); REAL erfc_(real *x) #endif { return( erfc((double)*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/err.c0000644000175000017500000001445211236375625013664 0ustar afrb2afrb2#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ #include "f2c.h" #ifdef KR_headers #define Const /*nothing*/ extern char *malloc(); #else #define Const const #undef abs #undef min #undef max #include "stdlib.h" #endif #include "fio.h" #include "fmt.h" /* for struct syl */ /* Compile this with -DNO_ISATTY if unistd.h does not exist or */ /* if it does not define int isatty(int). */ #ifdef NO_ISATTY #define isatty(x) 0 #else #include #endif #ifdef __cplusplus extern "C" { #endif /*global definitions*/ unit f__units[MXUNIT]; /*unit table*/ flag f__init; /*0 on entry, 1 after initializations*/ cilist *f__elist; /*active external io list*/ icilist *f__svic; /*active internal io list*/ flag f__reading; /*1 if reading, 0 if writing*/ flag f__cplus,f__cblank; Const char *f__fmtbuf; flag f__external; /*1 if external io, 0 if internal */ #ifdef KR_headers int (*f__doed)(),(*f__doned)(); int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); int (*f__getn)(); /* for formatted input */ void (*f__putn)(); /* for formatted output */ #else int (*f__getn)(void); /* for formatted input */ void (*f__putn)(int); /* for formatted output */ int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); #endif flag f__sequential; /*1 if sequential io, 0 if direct*/ flag f__formatted; /*1 if formatted io, 0 if unformatted*/ FILE *f__cf; /*current file*/ unit *f__curunit; /*current unit*/ int f__recpos; /*place in current record*/ OFF_T f__cursor, f__hiwater; int f__scale; char *f__icptr; /*error messages*/ Const char *F_err[] = { "error in format", /* 100 */ "illegal unit number", /* 101 */ "formatted io not allowed", /* 102 */ "unformatted io not allowed", /* 103 */ "direct io not allowed", /* 104 */ "sequential io not allowed", /* 105 */ "can't backspace file", /* 106 */ "null file name", /* 107 */ "can't stat file", /* 108 */ "unit not connected", /* 109 */ "off end of record", /* 110 */ "truncation failed in endfile", /* 111 */ "incomprehensible list input", /* 112 */ "out of free space", /* 113 */ "unit not connected", /* 114 */ "read unexpected character", /* 115 */ "bad logical input field", /* 116 */ "bad variable type", /* 117 */ "bad namelist name", /* 118 */ "variable not in namelist", /* 119 */ "no end record", /* 120 */ "variable count incorrect", /* 121 */ "subscript for scalar variable", /* 122 */ "invalid array section", /* 123 */ "substring out of bounds", /* 124 */ "subscript out of bounds", /* 125 */ "can't read file", /* 126 */ "can't write file", /* 127 */ "'new' file exists", /* 128 */ "can't append to file", /* 129 */ "non-positive record number", /* 130 */ "nmLbuf overflow" /* 131 */ }; #define MAXERR (sizeof(F_err)/sizeof(char *)+100) int #ifdef KR_headers f__canseek(f) FILE *f; /*SYSDEP*/ #else f__canseek(FILE *f) /*SYSDEP*/ #endif { #ifdef NON_UNIX_STDIO return !isatty(fileno(f)); #else struct STAT_ST x; if (FSTAT(fileno(f),&x) < 0) return(0); #ifdef S_IFMT switch(x.st_mode & S_IFMT) { case S_IFDIR: case S_IFREG: if(x.st_nlink > 0) /* !pipe */ return(1); else return(0); case S_IFCHR: if(isatty(fileno(f))) return(0); return(1); #ifdef S_IFBLK case S_IFBLK: return(1); #endif } #else #ifdef S_ISDIR /* POSIX version */ if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { if(x.st_nlink > 0) /* !pipe */ return(1); else return(0); } if (S_ISCHR(x.st_mode)) { if(isatty(fileno(f))) return(0); return(1); } if (S_ISBLK(x.st_mode)) return(1); #else Help! How does fstat work on this system? #endif #endif return(0); /* who knows what it is? */ #endif } void #ifdef KR_headers f__fatal(n,s) char *s; #else f__fatal(int n, const char *s) #endif { if(n<100 && n>=0) perror(s); /*SYSDEP*/ else if(n >= (int)MAXERR || n < -1) { fprintf(stderr,"%s: illegal error number %d\n",s,n); } else if(n == -1) fprintf(stderr,"%s: end of file\n",s); else fprintf(stderr,"%s: %s\n",s,F_err[n-100]); if (f__curunit) { fprintf(stderr,"apparent state: unit %d ", (int)(f__curunit-f__units)); fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", f__curunit->ufnm); } else fprintf(stderr,"apparent state: internal I/O\n"); if (f__fmtbuf) fprintf(stderr,"last format: %s\n",f__fmtbuf); fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", f__external?"external":"internal"); sig_die(" IO", 1); } /*initialization routine*/ VOID f_init(Void) { unit *p; f__init=1; p= &f__units[0]; p->ufd=stderr; p->useek=f__canseek(stderr); p->ufmt=1; p->uwrt=1; p = &f__units[5]; p->ufd=stdin; p->useek=f__canseek(stdin); p->ufmt=1; p->uwrt=0; p= &f__units[6]; p->ufd=stdout; p->useek=f__canseek(stdout); p->ufmt=1; p->uwrt=1; } int #ifdef KR_headers f__nowreading(x) unit *x; #else f__nowreading(unit *x) #endif { OFF_T loc; int ufmt, urw; extern char *f__r_mode[], *f__w_mode[]; if (x->urw & 1) goto done; if (!x->ufnm) goto cantread; ufmt = x->url ? 0 : x->ufmt; loc = FTELL(x->ufd); urw = 3; if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { urw = 1; if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) { cantread: errno = 126; return 1; } } FSEEK(x->ufd,loc,SEEK_SET); x->urw = urw; done: x->uwrt = 0; return 0; } int #ifdef KR_headers f__nowwriting(x) unit *x; #else f__nowwriting(unit *x) #endif { OFF_T loc; int ufmt; extern char *f__w_mode[]; if (x->urw & 2) { if (x->urw & 1) FSEEK(x->ufd, (OFF_T)0, SEEK_CUR); goto done; } if (!x->ufnm) goto cantwrite; ufmt = x->url ? 0 : x->ufmt; if (x->uwrt == 3) { /* just did write, rewind */ if (!(f__cf = x->ufd = FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd))) goto cantwrite; x->urw = 2; } else { loc=FTELL(x->ufd); if (!(f__cf = x->ufd = FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) { x->ufd = NULL; cantwrite: errno = 127; return(1); } x->urw = 3; FSEEK(x->ufd,loc,SEEK_SET); } done: x->uwrt = 1; return 0; } int #ifdef KR_headers err__fl(f, m, s) int f, m; char *s; #else err__fl(int f, int m, const char *s) #endif { if (!f) f__fatal(m, s); if (f__doend) (*f__doend)(); return errno = m; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/etime_.c0000644000175000017500000000150711236375625014333 0ustar afrb2afrb2#include "time.h" #ifdef MSDOS #undef USE_CLOCK #define USE_CLOCK #endif #ifndef REAL #define REAL double #endif #ifndef USE_CLOCK #define _INCLUDE_POSIX_SOURCE /* for HP-UX */ #define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ #include "sys/types.h" #include "sys/times.h" #ifdef __cplusplus extern "C" { #endif #endif #undef Hz #ifdef CLK_TCK #define Hz CLK_TCK #else #ifdef HZ #define Hz HZ #else #define Hz 60 #endif #endif REAL #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] = (double)t.tms_utime/Hz) + (tarray[1] = (double)t.tms_stime/Hz); #endif } #ifdef __cplusplus } #endif libf2c2-20090411.orig/exit_.c0000644000175000017500000000103711236375625014177 0ustar afrb2afrb2/* 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 #ifdef __cplusplus extern "C" { #endif extern void f_exit(void); #endif void #ifdef KR_headers exit_(rc) integer *rc; #else exit_(integer *rc) #endif { #ifdef NO_ONEXIT f_exit(); #endif exit(*rc); } #ifdef __cplusplus } #endif #ifdef __cplusplus } #endif libf2c2-20090411.orig/f2c.h00000644000175000017500000001112011236375625013620 0ustar afrb2afrb2/* f2c.h -- Standard Fortran to C header file */ /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ #ifndef F2C_INCLUDE #define F2C_INCLUDE typedef long int integer; typedef unsigned long int uinteger; typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; typedef long int logical; typedef short int shortlogical; typedef char logical1; typedef char integer1; #ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ typedef long long longint; /* system-dependent */ typedef unsigned long long ulongint; /* system-dependent */ #define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) #define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) #endif #define TRUE_ (1) #define FALSE_ (0) /* Extern is for use with -E */ #ifndef Extern #define Extern extern #endif /* I/O stuff */ #ifdef f2c_i2 /* for -i2 */ typedef short flag; typedef short ftnlen; typedef short ftnint; #else typedef long int flag; typedef long int ftnlen; typedef long int ftnint; #endif /*external read, write*/ typedef struct { flag cierr; ftnint ciunit; flag ciend; char *cifmt; ftnint cirec; } cilist; /*internal read, write*/ typedef struct { flag icierr; char *iciunit; flag iciend; char *icifmt; ftnint icirlen; ftnint icirnum; } icilist; /*open*/ typedef struct { flag oerr; ftnint ounit; char *ofnm; ftnlen ofnmlen; char *osta; char *oacc; char *ofm; ftnint orl; char *oblnk; } olist; /*close*/ typedef struct { flag cerr; ftnint cunit; char *csta; } cllist; /*rewind, backspace, endfile*/ typedef struct { flag aerr; ftnint aunit; } alist; /* inquire */ typedef struct { flag inerr; ftnint inunit; char *infile; ftnlen infilen; ftnint *inex; /*parameters in standard's order*/ ftnint *inopen; ftnint *innum; ftnint *innamed; char *inname; ftnlen innamlen; char *inacc; ftnlen inacclen; char *inseq; ftnlen inseqlen; char *indir; ftnlen indirlen; char *infmt; ftnlen infmtlen; char *inform; ftnint informlen; char *inunf; ftnlen inunflen; ftnint *inrecl; ftnint *innrec; char *inblank; ftnlen inblanklen; } inlist; #define VOID void union Multitype { /* for multiple entry points */ integer1 g; shortint h; integer i; /* longint j; */ real r; doublereal d; complex c; doublecomplex z; }; typedef union Multitype Multitype; /*typedef long int Long;*/ /* No longer used; formerly in Namelist */ struct Vardesc { /* for Namelist */ char *name; char *addr; ftnlen *dims; int type; }; typedef struct Vardesc Vardesc; struct Namelist { char *name; Vardesc **vars; int nvars; }; typedef struct Namelist Namelist; #define abs(x) ((x) >= 0 ? (x) : -(x)) #define dabs(x) (doublereal)abs(x) #define min(a,b) ((a) <= (b) ? (a) : (b)) #define max(a,b) ((a) >= (b) ? (a) : (b)) #define dmin(a,b) (doublereal)min(a,b) #define dmax(a,b) (doublereal)max(a,b) #define bit_test(a,b) ((a) >> (b) & 1) #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 #ifdef __cplusplus typedef int /* Unknown procedure type */ (*U_fp)(...); typedef shortint (*J_fp)(...); typedef integer (*I_fp)(...); typedef real (*R_fp)(...); typedef doublereal (*D_fp)(...), (*E_fp)(...); typedef /* Complex */ VOID (*C_fp)(...); typedef /* Double Complex */ VOID (*Z_fp)(...); typedef logical (*L_fp)(...); typedef shortlogical (*K_fp)(...); typedef /* Character */ VOID (*H_fp)(...); typedef /* Subroutine */ int (*S_fp)(...); #else typedef int /* Unknown procedure type */ (*U_fp)(); typedef shortint (*J_fp)(); typedef integer (*I_fp)(); typedef real (*R_fp)(); typedef doublereal (*D_fp)(), (*E_fp)(); typedef /* Complex */ VOID (*C_fp)(); typedef /* Double Complex */ VOID (*Z_fp)(); typedef logical (*L_fp)(); typedef shortlogical (*K_fp)(); typedef /* Character */ VOID (*H_fp)(); typedef /* Subroutine */ int (*S_fp)(); #endif /* E_fp is for real functions when -R is not specified */ typedef VOID C_f; /* complex function */ typedef VOID H_f; /* character function */ typedef VOID Z_f; /* double complex function */ typedef doublereal E_f; /* real function with -R not specified */ /* undef any lower-case symbols that your C compiler predefines, e.g.: */ #ifndef Skip_f2c_Undefs #undef cray #undef gcos #undef mc68010 #undef mc68020 #undef mips #undef pdp11 #undef sgi #undef sparc #undef sun #undef sun2 #undef sun3 #undef sun4 #undef u370 #undef u3b #undef u3b2 #undef u3b5 #undef unix #undef vax #endif #endif libf2c2-20090411.orig/f2ch.add0000644000175000017500000001365411236375625014227 0ustar afrb2afrb2/* 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 libf2c2-20090411.orig/f77_aloc.c0000644000175000017500000000125411236375625014471 0ustar afrb2afrb2#include "f2c.h" #undef abs #undef min #undef max #include "stdio.h" static integer memfailure = 3; #ifdef KR_headers extern char *malloc(); extern void exit_(); char * F77_aloc(Len, whence) integer Len; char *whence; #else #include "stdlib.h" #ifdef __cplusplus extern "C" { #endif #ifdef __cplusplus extern "C" { #endif extern void exit_(integer*); #ifdef __cplusplus } #endif char * F77_aloc(integer Len, const char *whence) #endif { char *rv; unsigned int uLen = (unsigned int) Len; /* for K&R C */ if (!(rv = (char*)malloc(uLen))) { fprintf(stderr, "malloc(%u) failure in %s\n", uLen, whence); exit_(&memfailure); } return rv; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/f77vers.c0000644000175000017500000001150511236375625014373 0ustar afrb2afrb2 char _libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20051004\n"; /* 2.00 11 June 1980. File version.c added to library. 2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed [ d]erf[c ] added 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c 29 Nov. 1989: s_cmp returns long (for f2c) 30 Nov. 1989: arg types from f2c.h 12 Dec. 1989: s_rnge allows long names 19 Dec. 1989: getenv_ allows unsorted environment 28 Mar. 1990: add exit(0) to end of main() 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main 17 Oct. 1990: abort() calls changed to sig_die(...,1) 22 Oct. 1990: separate sig_die from main 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die 31 May 1991: make system_ return status 18 Dec. 1991: change long to ftnlen (for -i2) many places 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c and m**n in pow_hh.c and pow_ii.c; catch SIGTRAP in main() for error msg before abort 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); change Cabs to f__cabs. 12 March 1993: various tweaks for C++ 2 June 1994: adjust so abnormal terminations invoke f_exit just once 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines that sign-extend right shifts when i is the most negative integer. 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side of character assignments to appear on the right-hand side (unless compiled with -DNO_OVERWRITE). 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever possible (for better cache behavior). 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. 6 Sept. 1995: fix return type of system_ under -DKR_headers. 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). 19 June 1996: add casts to unsigned in [lq]bitshft.c. 26 Feb. 1997: adjust functions with a complex output argument to permit aliasing it with input arguments. (For now, at least, this is just for possible benefit of g77.) 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may affect systems using gratuitous extra precision). 19 Sept. 1997: [de]time_.c (Unix systems only): change return type to double. 2 May 1999: getenv_.c: omit environ in favor of getenv(). c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c, z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with overlapping arguments caused by equivalence. 3 May 1999: "invisible" tweaks to omit compiler warnings in abort_.c, ef1asc_.c, s_rnge.c, s_stop.c. 7 Sept. 1999: [cz]_div.c: arrange for compilation under -DIEEE_COMPLEX_DIVIDE to make these routines avoid calling sig_die when the denominator vanishes; instead, they return pairs of NaNs or Infinities, depending whether the numerator also vanishes or not. VERSION not changed. 15 Nov. 1999: s_rnge.c: add casts for the case of sizeof(ftnint) == sizeof(int) < sizeof(long). 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g., z near (+-1,eps) with |eps| small. For the old evaluation, compile with -DPre20000310 . 20 April 2000: s_cat.c: tweak argument types to accord with calls by f2c when ftnint and ftnlen are of different sizes (different numbers of bits). 4 July 2000: adjustments to permit compilation by C++ compilers; VERSION string remains unchanged. 29 Sept. 2000: dtime_.c, etime_.c: use floating-point divide. dtime_.d, erf_.c, erfc_.c, etime.c: for use with "f2c -R", compile with -DREAL=float. 23 June 2001: add uninit.c; [fi]77vers.c: make version strings visible as extern char _lib[fi]77_version_f2c[]. 5 July 2001: modify uninit.c for __mc68k__ under Linux. 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain. 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type, missing ~ on y in return value. 14 March 2002: z_log.c: add code to cope with buggy compilers (e.g., some versions of gcc under -O2 or -O3) that do floating-point comparisons against values computed into extended-precision registers on some systems (such as Intel IA32 systems). Compile with -DNO_DOUBLE_EXTENDED to omit the new logic. 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables. 10 Oct 2005: uninit.c: on IA32 Linux systems, leave the rounding precision alone rather than forcing it to 53 bits; compile with -DUNINIT_F2C_PRECISION_53 to get the former behavior. */ libf2c2-20090411.orig/fio.h0000644000175000017500000000557311236375625013662 0ustar afrb2afrb2#ifndef SYSDEP_H_INCLUDED #include "sysdep1.h" #endif #include "stdio.h" #include "errno.h" #ifndef NULL /* ANSI C */ #include "stddef.h" #endif #ifndef SEEK_SET #define SEEK_SET 0 #define SEEK_CUR 1 #define SEEK_END 2 #endif #ifndef FOPEN #define FOPEN fopen #endif #ifndef FREOPEN #define FREOPEN freopen #endif #ifndef FSEEK #define FSEEK fseek #endif #ifndef FSTAT #define FSTAT fstat #endif #ifndef FTELL #define FTELL ftell #endif #ifndef OFF_T #define OFF_T long #endif #ifndef STAT_ST #define STAT_ST stat #endif #ifndef STAT #define STAT stat #endif #ifdef MSDOS #ifndef NON_UNIX_STDIO #define NON_UNIX_STDIO #endif #endif #ifdef UIOLEN_int typedef int uiolen; #else typedef long uiolen; #endif /*units*/ typedef struct { FILE *ufd; /*0=unconnected*/ char *ufnm; #ifndef MSDOS long uinode; int udev; #endif int url; /*0=sequential*/ flag useek; /*true=can backspace, use dir, ...*/ flag ufmt; flag urw; /* (1 for can read) | (2 for can write) */ flag ublnk; flag uend; flag uwrt; /*last io was write*/ flag uscrtch; } unit; #undef Void #ifdef KR_headers #define Void /*void*/ extern int (*f__getn)(); /* for formatted input */ extern void (*f__putn)(); /* for formatted output */ extern void x_putc(); extern long f__inode(); extern VOID sig_die(); extern int (*f__donewrec)(), t_putc(), x_wSL(); extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); #else #define Void void #ifdef __cplusplus extern "C" { #endif extern int (*f__getn)(void); /* for formatted input */ extern void (*f__putn)(int); /* for formatted output */ extern void x_putc(int); extern long f__inode(char*,int*); extern void sig_die(const char*,int); extern void f__fatal(int, const char*); extern int t_runc(alist*); extern int f__nowreading(unit*), f__nowwriting(unit*); extern int fk_open(int,int,ftnint); extern int en_fio(void); extern void f_init(void); extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); extern void b_char(const char*,char*,ftnlen), g_char(const char*,ftnlen,char*); extern int c_sfe(cilist*), z_rnew(void); extern int err__fl(int,int,const char*); extern int xrd_SL(void); extern int f__putbuf(int); #endif extern flag f__init; extern cilist *f__elist; /*active external io list*/ extern flag f__reading,f__external,f__sequential,f__formatted; extern int (*f__doend)(Void); extern FILE *f__cf; /*current file*/ extern unit *f__curunit; /*current unit*/ extern unit f__units[]; #define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);} #define errfl(f,m,s) return err__fl((int)f,m,s) /*Table sizes*/ #define MXUNIT 100 extern int f__recpos; /*position in current record*/ extern OFF_T f__cursor; /* offset to move to */ extern OFF_T f__hiwater; /* so TL doesn't confuse us */ #ifdef __cplusplus } #endif #define WRITE 1 #define READ 2 #define SEQ 3 #define DIR 4 #define FMT 5 #define UNF 6 #define EXT 7 #define INT 8 #define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) libf2c2-20090411.orig/fmt.c0000644000175000017500000002056611236375625013665 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "fmt.h" #ifdef __cplusplus extern "C" { #endif #define skip(s) while(*s==' ') s++ #ifdef interdata #define SYLMX 300 #endif #ifdef pdp11 #define SYLMX 300 #endif #ifdef vax #define SYLMX 300 #endif #ifndef SYLMX #define SYLMX 300 #endif #define GLITCH '\2' /* special quote character for stu */ extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ static struct syl f__syl[SYLMX]; int f__parenlvl,f__pc,f__revloc; #ifdef KR_headers #define Const /*nothing*/ #else #define Const const #endif static #ifdef KR_headers char *ap_end(s) char *s; #else const char *ap_end(const char *s) #endif { char quote; quote= *s++; for(;*s;s++) { if(*s!=quote) continue; if(*++s!=quote) return(s); } if(f__elist->cierr) { errno = 100; return(NULL); } f__fatal(100, "bad string"); /*NOTREACHED*/ return 0; } static int #ifdef KR_headers op_gen(a,b,c,d) #else op_gen(int a, int b, int c, int d) #endif { struct syl *p= &f__syl[f__pc]; if(f__pc>=SYLMX) { fprintf(stderr,"format too complicated:\n"); sig_die(f__fmtbuf, 1); } p->op=a; p->p1=b; p->p2.i[0]=c; p->p2.i[1]=d; return(f__pc++); } #ifdef KR_headers static char *f_list(); static char *gt_num(s,n,n1) char *s; int *n, n1; #else static const char *f_list(const char*); static const char *gt_num(const char *s, int *n, int n1) #endif { int m=0,f__cnt=0; char c; for(c= *s;;c = *s) { if(c==' ') { s++; continue; } if(c>'9' || c<'0') break; m=10*m+c-'0'; f__cnt++; s++; } if(f__cnt==0) { if (!n1) s = 0; *n=n1; } else *n=m; return(s); } static #ifdef KR_headers char *f_s(s,curloc) char *s; #else const char *f_s(const char *s, int curloc) #endif { skip(s); if(*s++!='(') { return(NULL); } if(f__parenlvl++ ==1) f__revloc=curloc; if(op_gen(RET1,curloc,0,0)<0 || (s=f_list(s))==NULL) { return(NULL); } skip(s); return(s); } static int #ifdef KR_headers ne_d(s,p) char *s,**p; #else ne_d(const char *s, const char **p) #endif { int n,x,sign=0; struct syl *sp; switch(*s) { default: return(0); case ':': (void) op_gen(COLON,0,0,0); break; case '$': (void) op_gen(NONL, 0, 0, 0); break; case 'B': case 'b': if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); else (void) op_gen(BN,0,0,0); break; case 'S': case 's': if(*(s+1)=='s' || *(s+1) == 'S') { x=SS; s++; } else if(*(s+1)=='p' || *(s+1) == 'P') { x=SP; s++; } else x=S; (void) op_gen(x,0,0,0); break; case '/': (void) op_gen(SLASH,0,0,0); break; case '-': sign=1; case '+': s++; /*OUTRAGEOUS CODING TRICK*/ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (!(s=gt_num(s,&n,0))) { bad: *p = 0; return 1; } switch(*s) { default: return(0); case 'P': case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; case 'X': case 'x': (void) op_gen(X,n,0,0); break; case 'H': case 'h': sp = &f__syl[op_gen(H,n,0,0)]; sp->p2.s = (char*)s + 1; s+=n; break; } break; case GLITCH: case '"': case '\'': sp = &f__syl[op_gen(APOS,0,0,0)]; sp->p2.s = (char*)s; if((*p = ap_end(s)) == NULL) return(0); return(1); case 'T': case 't': if(*(s+1)=='l' || *(s+1) == 'L') { x=TL; s++; } else if(*(s+1)=='r'|| *(s+1) == 'R') { x=TR; s++; } else x=T; if (!(s=gt_num(s+1,&n,0))) goto bad; s--; (void) op_gen(x,n,0,0); break; case 'X': case 'x': (void) op_gen(X,1,0,0); break; case 'P': case 'p': (void) op_gen(P,1,0,0); break; } s++; *p=s; return(1); } static int #ifdef KR_headers e_d(s,p) char *s,**p; #else e_d(const char *s, const char **p) #endif { int i,im,n,w,d,e,found=0,x=0; Const char *sv=s; s=gt_num(s,&n,1); (void) op_gen(STACK,n,0,0); switch(*s++) { default: break; case 'E': case 'e': x=1; case 'G': case 'g': found=1; if (!(s=gt_num(s,&w,0))) { bad: *p = 0; return 1; } if(w==0) break; if(*s=='.') { if (!(s=gt_num(s+1,&d,0))) goto bad; } else d=0; if(*s!='E' && *s != 'e') (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ else { if (!(s=gt_num(s+1,&e,0))) goto bad; (void) op_gen(x==1?EE:GE,w,d,e); } break; case 'O': case 'o': i = O; im = OM; goto finish_I; case 'Z': case 'z': i = Z; im = ZM; goto finish_I; case 'L': case 'l': found=1; if (!(s=gt_num(s,&w,0))) goto bad; if(w==0) break; (void) op_gen(L,w,0,0); break; case 'A': case 'a': found=1; skip(s); if(*s>='0' && *s<='9') { s=gt_num(s,&w,1); if(w==0) break; (void) op_gen(AW,w,0,0); break; } (void) op_gen(A,0,0,0); break; case 'F': case 'f': if (!(s=gt_num(s,&w,0))) goto bad; found=1; if(w==0) break; if(*s=='.') { if (!(s=gt_num(s+1,&d,0))) goto bad; } else d=0; (void) op_gen(F,w,d,0); break; case 'D': case 'd': found=1; if (!(s=gt_num(s,&w,0))) goto bad; if(w==0) break; if(*s=='.') { if (!(s=gt_num(s+1,&d,0))) goto bad; } else d=0; (void) op_gen(D,w,d,0); break; case 'I': case 'i': i = I; im = IM; finish_I: if (!(s=gt_num(s,&w,0))) goto bad; found=1; if(w==0) break; if(*s!='.') { (void) op_gen(i,w,0,0); break; } if (!(s=gt_num(s+1,&d,0))) goto bad; (void) op_gen(im,w,d,0); break; } if(found==0) { f__pc--; /*unSTACK*/ *p=sv; return(0); } *p=s; return(1); } static #ifdef KR_headers char *i_tem(s) char *s; #else const char *i_tem(const char *s) #endif { const char *t; int n,curloc; if(*s==')') return(s); if(ne_d(s,&t)) return(t); if(e_d(s,&t)) return(t); s=gt_num(s,&n,1); if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); return(f_s(s,curloc)); } static #ifdef KR_headers char *f_list(s) char *s; #else const char *f_list(const char *s) #endif { for(;*s!=0;) { skip(s); if((s=i_tem(s))==NULL) return(NULL); skip(s); if(*s==',') s++; else if(*s==')') { if(--f__parenlvl==0) { (void) op_gen(REVERT,f__revloc,0,0); return(++s); } (void) op_gen(GOTO,0,0,0); return(++s); } } return(NULL); } int #ifdef KR_headers pars_f(s) char *s; #else pars_f(const char *s) #endif { f__parenlvl=f__revloc=f__pc=0; if(f_s(s,0) == NULL) { return(-1); } return(0); } #define STKSZ 10 int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; flag f__workdone, f__nonl; static int #ifdef KR_headers type_f(n) #else type_f(int n) #endif { switch(n) { default: return(n); case RET1: return(RET1); case REVERT: return(REVERT); case GOTO: return(GOTO); case STACK: return(STACK); case X: case SLASH: case APOS: case H: case T: case TL: case TR: return(NED); case F: case I: case IM: case A: case AW: case O: case OM: case L: case E: case EE: case D: case G: case GE: case Z: case ZM: return(ED); } } #ifdef KR_headers integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; #else integer do_fio(ftnint *number, char *ptr, ftnlen len) #endif { struct syl *p; int n,i; for(i=0;i<*number;i++,ptr+=len) { loop: switch(type_f((p= &f__syl[f__pc])->op)) { default: fprintf(stderr,"unknown code in do_fio: %d\n%s\n", p->op,f__fmtbuf); err(f__elist->cierr,100,"do_fio"); case NED: if((*f__doned)(p)) { f__pc++; goto loop; } f__pc++; continue; case ED: if(f__cnt[f__cp]<=0) { f__cp--; f__pc++; goto loop; } if(ptr==NULL) return((*f__doend)()); f__cnt[f__cp]--; f__workdone=1; if((n=(*f__doed)(p,ptr,len))>0) errfl(f__elist->cierr,errno,"fmt"); if(n<0) err(f__elist->ciend,(EOF),"fmt"); continue; case STACK: f__cnt[++f__cp]=p->p1; f__pc++; goto loop; case RET1: f__ret[++f__rp]=p->p1; f__pc++; goto loop; case GOTO: if(--f__cnt[f__cp]<=0) { f__cp--; f__rp--; f__pc++; goto loop; } f__pc=1+f__ret[f__rp--]; goto loop; case REVERT: f__rp=f__cp=0; f__pc = p->p1; if(ptr==NULL) return((*f__doend)()); if(!f__workdone) return(0); if((n=(*f__dorevert)()) != 0) return(n); goto loop; case COLON: if(ptr==NULL) return((*f__doend)()); f__pc++; goto loop; case NONL: f__nonl = 1; f__pc++; goto loop; case S: case SS: f__cplus=0; f__pc++; goto loop; case SP: f__cplus = 1; f__pc++; goto loop; case P: f__scale=p->p1; f__pc++; goto loop; case BN: f__cblank=0; f__pc++; goto loop; case BZ: f__cblank=1; f__pc++; goto loop; } } return(0); } int en_fio(Void) { ftnint one=1; return(do_fio(&one,(char *)NULL,(ftnint)0)); } VOID fmt_bg(Void) { f__workdone=f__cp=f__rp=f__pc=f__cursor=0; f__cnt[0]=f__ret[0]=0; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/fmt.h0000644000175000017500000000372611236375625013671 0ustar afrb2afrb2struct syl { int op; int p1; union { int i[2]; char *s;} p2; }; #define RET1 1 #define REVERT 2 #define GOTO 3 #define X 4 #define SLASH 5 #define STACK 6 #define I 7 #define ED 8 #define NED 9 #define IM 10 #define APOS 11 #define H 12 #define TL 13 #define TR 14 #define T 15 #define COLON 16 #define S 17 #define SP 18 #define SS 19 #define P 20 #define BN 21 #define BZ 22 #define F 23 #define E 24 #define EE 25 #define D 26 #define G 27 #define GE 28 #define L 29 #define A 30 #define AW 31 #define O 32 #define NONL 33 #define OM 34 #define Z 35 #define ZM 36 typedef union { real pf; doublereal pd; } ufloat; typedef union { short is; #ifndef KR_headers signed #endif char ic; integer il; #ifdef Allow_TYQUAD longint ili; #endif } Uint; #ifdef KR_headers extern int (*f__doed)(),(*f__doned)(); extern int (*f__dorevert)(); extern int rd_ed(),rd_ned(); extern int w_ed(),w_ned(); extern int signbit_f2c(); extern char *f__fmtbuf; #else #ifdef __cplusplus extern "C" { #define Cextern extern "C" #else #define Cextern extern #endif extern const char *f__fmtbuf; extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); extern int (*f__dorevert)(void); extern void fmt_bg(void); extern int pars_f(const char*); extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); extern int signbit_f2c(double*); extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); extern int wrt_E(ufloat*, int, int, int, ftnlen); extern int wrt_F(ufloat*, int, int, ftnlen); extern int wrt_L(Uint*, int, ftnlen); #endif extern int f__pc,f__parenlvl,f__revloc; extern flag f__cblank,f__cplus,f__workdone, f__nonl; extern int f__scale; #ifdef __cplusplus } #endif #define GET(x) if((x=(*f__getn)())<0) return(x) #define VAL(x) (x!='\n'?x:' ') #define PUT(x) (*f__putn)(x) #undef TYQUAD #ifndef Allow_TYQUAD #undef longint #define longint long #else #define TYQUAD 14 #endif #ifdef KR_headers extern char *f__icvt(); #else Cextern char *f__icvt(longint, int*, int*, int); #endif libf2c2-20090411.orig/fmtlib.c0000644000175000017500000000154111236375625014344 0ustar afrb2afrb2/* @(#)fmtlib.c 1.2 */ #define MAXINTLENGTH 23 #include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifndef Allow_TYQUAD #undef longint #define longint long #undef ulongint #define ulongint unsigned long #endif #ifdef KR_headers char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; register int base; #else char *f__icvt(longint value, int *ndigit, int *sign, int base) #endif { static char buf[MAXINTLENGTH+1]; register int i; ulongint uvalue; if(value > 0) { uvalue = value; *sign = 0; } else if (value < 0) { uvalue = -value; *sign = 1; } else { *sign = 0; *ndigit = 1; buf[MAXINTLENGTH-1] = '0'; return &buf[MAXINTLENGTH-1]; } i = MAXINTLENGTH; do { buf[--i] = (uvalue%base) + '0'; uvalue /= base; } while(uvalue > 0); *ndigit = MAXINTLENGTH - i; return &buf[i]; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/fp.h0000644000175000017500000000123111236375625013475 0ustar afrb2afrb2#define FMAX 40 #define EXPMAXDIGS 8 #define EXPMAX 99999999 /* FMAX = max number of nonzero digits passed to atof() */ /* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ #ifdef V10 /* Research Tenth-Edition Unix */ #include "local.h" #endif /* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily tight) on the maximum number of digits to the right and left of * the decimal point. */ #ifdef VAX #define MAXFRACDIGS 56 #define MAXINTDIGS 38 #else #ifdef CRAY #define MAXFRACDIGS 9880 #define MAXINTDIGS 9864 #else /* values that suffice for IEEE double */ #define MAXFRACDIGS 344 #define MAXINTDIGS 308 #endif #endif libf2c2-20090411.orig/ftell64_.c0000644000175000017500000000162511236375625014511 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif static FILE * #ifdef KR_headers unit_chk(Unit, who) integer Unit; char *who; #else unit_chk(integer Unit, char *who) #endif { if (Unit >= MXUNIT || Unit < 0) f__fatal(101, who); return f__units[Unit].ufd; } longint #ifdef KR_headers ftell64_(Unit) integer *Unit; #else ftell64_(integer *Unit) #endif { FILE *f; return (f = unit_chk(*Unit, "ftell")) ? FTELL(f) : -1L; } int #ifdef KR_headers fseek64_(Unit, offset, whence) integer *Unit, *whence; longint *offset; #else fseek64_(integer *Unit, longint *offset, integer *whence) #endif { FILE *f; int w = (int)*whence; #ifdef SEEK_SET static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; #endif if (w < 0 || w > 2) w = 0; #ifdef SEEK_SET w = wohin[w]; #endif return !(f = unit_chk(*Unit, "fseek")) || FSEEK(f, (OFF_T)*offset, w) ? 1 : 0; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/ftell_.c0000644000175000017500000000160411236375625014334 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif static FILE * #ifdef KR_headers unit_chk(Unit, who) integer Unit; char *who; #else unit_chk(integer Unit, const char *who) #endif { if (Unit >= MXUNIT || Unit < 0) f__fatal(101, who); return f__units[Unit].ufd; } integer #ifdef KR_headers ftell_(Unit) integer *Unit; #else ftell_(integer *Unit) #endif { FILE *f; return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; } int #ifdef KR_headers fseek_(Unit, offset, whence) integer *Unit, *offset, *whence; #else fseek_(integer *Unit, integer *offset, integer *whence) #endif { FILE *f; int w = (int)*whence; #ifdef SEEK_SET static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; #endif if (w < 0 || w > 2) w = 0; #ifdef SEEK_SET w = wohin[w]; #endif return !(f = unit_chk(*Unit, "fseek")) || fseek(f, *offset, w) ? 1 : 0; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/getarg_.c0000644000175000017500000000112011236375625014470 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif /* * 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; char *s; ftnlen ls; #define Const /*nothing*/ #else #define Const const void getarg_(ftnint *n, char *s, ftnlen ls) #endif { extern int xargc; extern char **xargv; Const char *t; int i; if(*n>=0 && *n #include #ifdef __cplusplus extern "C" { #endif extern char *F77_aloc(ftnlen, const char*); #endif /* * 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 { char buf[256], *ep, *fp; integer i; if (flen <= 0) goto add_blanks; for(i = 0; i < sizeof(buf); i++) { if (i == flen || (buf[i] = fname[i]) == ' ') { buf[i] = 0; ep = getenv(buf); goto have_ep; } } while(i < flen && fname[i] != ' ') i++; strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i); fp[i] = 0; ep = getenv(fp); free(fp); have_ep: if (ep) while(*ep && vlen-- > 0) *value++ = *ep++; add_blanks: while(vlen-- > 0) *value++ = ' '; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_abs.c0000644000175000017500000000033211236375625014140 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers shortint h_abs(x) shortint *x; #else shortint h_abs(shortint *x) #endif { if(*x >= 0) return(*x); return(- *x); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_dim.c0000644000175000017500000000034611236375625014151 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_dnnt.c0000644000175000017500000000044611236375625014344 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); shortint h_dnnt(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif shortint h_dnnt(doublereal *x) #endif { return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_indx.c0000644000175000017500000000067211236375625014344 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_len.c0000644000175000017500000000031511236375625014152 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers shortint h_len(s, n) char *s; ftnlen n; #else shortint h_len(char *s, ftnlen n) #endif { return(n); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_mod.c0000644000175000017500000000031711236375625014155 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers shortint h_mod(a,b) short *a, *b; #else shortint h_mod(short *a, short *b) #endif { return( *a % *b); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_nint.c0000644000175000017500000000043111236375625014343 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); shortint h_nint(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif shortint h_nint(real *x) #endif { return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/h_sign.c0000644000175000017500000000041211236375625014332 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/hl_ge.c0000644000175000017500000000053211236375625014144 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/hl_gt.c0000644000175000017500000000053111236375625014162 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/hl_le.c0000644000175000017500000000053211236375625014151 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/hl_lt.c0000644000175000017500000000053111236375625014167 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i77vers.c0000644000175000017500000004332011236375625014376 0ustar afrb2afrb2 char _libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n"; /* 2.01 $ format added 2.02 Coding bug in open.c repaired 2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c and lio.h (e-format conforming to spec) 2.04 changed open.c and err.c (fopen and freopen respectively) to update to new c-library (append mode) 2.05 added namelist capability 2.06 allow internal list and namelist I/O */ /* close.c: allow upper-case STATUS= values endfile.c create fort.nnn if unit nnn not open; else if (file length == 0) use creat() rather than copy; use local copy() rather than forking /bin/cp; rewind, fseek to clear buffer (for no reading past EOF) err.c use neither setbuf nor setvbuf; make stderr buffered fio.h #define _bufend inquire.c upper case responses; omit byfile test from SEQUENTIAL= answer "YES" to DIRECT= for unopened file (open to debate) lio.c flush stderr, stdout at end of each stmt space before character strings in list output only at line start lio.h adjust LEW, LED consistent with old libI77 lread.c use atof() allow "nnn*," when reading complex constants open.c try opening for writing when open for read fails, with special uwrt value (2) delaying creat() to first write; set curunit so error messages don't drop core; no file name ==> fort.nnn except for STATUS='SCRATCH' rdfmt.c use atof(); trust EOF == end-of-file (so don't read past end-of-file after endfile stmt) sfe.c flush stderr, stdout at end of each stmt wrtfmt.c: use upper case put wrt_E and wrt_F into wref.c, use sprintf() rather than ecvt() and fcvt() [more accurate on VAX] */ /* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ /* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ /* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ /* 29 Nov. 1989: change various int return types to long for f2c */ /* 30 Nov. 1989: various types from f2c.h */ /* 6 Dec. 1989: types corrected various places */ /* 19 Dec. 1989: make iostat= work right for internal I/O */ /* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ /* 28 Jan. 1990: have NAMELIST read treat $ as &, general white space as blank */ /* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads of logical values reject letters other than fFtT; have nowwriting reset cf */ /* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ /* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as blank='z...' when reopening an open file */ /* 30 Aug. 1990: prevent embedded blanks in list output of complex values; omit exponent field in list output of values of magnitude between 10 and 1e8; prevent writing stdin and reading stdout or stderr; don't close stdin, stdout, or stderr when reopening units 5, 6, 0. */ /* 18 Sep. 1990: add component udev to unit and consider old == new file iff uinode and udev values agree; use stat rather than access to check existence of file (when STATUS='OLD')*/ /* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write don't clobber the file. */ /* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; adjust g_char in util.c for segmented memories. */ /* 17 Oct. 1990: replace abort() and _cleanup() with calls on sig_die(...,1) (defined in main.c). */ /* 5 Nov. 1990: changes to open.c: complain if new= is specified and the file already exists; allow file= to be omitted in open stmts and allow status='replace' (Fortran 90 extensions). */ /* 11 Dec. 1990: adjustments for POSIX. */ /* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from strings in read-only memory. */ /* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ /* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ /* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ /* 17 Oct. 1991: change type of length field in sequential unformatted records from int to long (for systems where sizeof(int) can vary, depending on the compiler or compiler options). */ /* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ /* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ /* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); adjust an error return from EOF to off end of record */ /* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused the last character of each record to be ignored. iio.c: adjust error message in internal formatted input from "end-of-file" to "off end of record" if the format specifies more characters than the record contains. */ /* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input, treat "r* ," and "r*," alike (where r is a positive integer constant), and fix a bug in handling null values following items with repeat counts (e.g., 2*1,,3); for namelist reading of a numeric array, allow a new name-value subsequence to terminate the current one (as though the current one ended with the right number of null values). lio.h, lwrite.c: omit insignificant zeros in list and namelist output. To get the old behavior, compile with -DOld_list_output . */ /* 18 Jan. 1992: make list output consistent with F format by printing .1 rather than 0.1 (introduced yesterday). */ /* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the character following a comma to be ignored. */ /* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= work with internal list and formatted I/O. */ /* 18 July 1992: adjust rsne.c to allow namelist input to stop at an & (e.g. &end). */ /* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; recognize Z format (assuming 8-bit bytes). */ /* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ /* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c (so end-of-file on other files won't confuse namelist reads of external files). Prepend f__ to external names that are only of internal interest to lib[FI]77. */ /* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd buffer == '\n'. endfile.c: guard against tiny L_tmpnam; close and reopen files in t_runc(). lio.h: lengthen LINTW (buffer size in lwrite.c). err.c, open.c: more prepending of f__ (to [rw]_mode). */ /* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being sought; namelists of the wrong name are skipped (after an error message; xwsne.c: namelist writes have a newline before each new variable. open.c: ACCESS='APPEND' positions sequential files at EOF (nonstandard extension -- that doesn't require changing data structures). */ /* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) when the unit has another file descriptor for name. */ /* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; open.c: always give f__w_mode[] 4 elements for use in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ /* 6 March 1993: uio.c: adjust off-end-of-record test for sequential unformatted reads to respond to err= rather than end=. */ /* 12 March 1993: various tweaks for C++ */ /* 6 April 1993: adjust error returns for formatted inputs to flush the current input line when err=label is specified. To restore the old behavior (input left mid-line), either adjust the #definition of errfl in fio.h or omit the invocation of f__doend in err__fl (in err.c). */ /* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ /* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for logical data (during list or namelist input). Change struct f__syl to struct syl (for buggy compilers). */ /* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete logical arrays. */ /* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete array of numeric data followed by another namelist item whose name starts with 'd', 'D', 'e', or 'E'. */ /* 8 Sept. 1993: open.c: protect #include "sys/..." with #ifndef NON_UNIX_STDIO; Version date not changed. */ /* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ /* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat short records as though padded with blanks (rather than causing an "off end of record" error). */ /* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ /* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct formatted files (avoiding any confusion regarding \n). */ /* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files under NON_UNIX_STDIO. */ /* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an optimization that requires exponents to have 2 digits when 2 digits suffice. lwrite.c wsfe.c (list and formatted external output): omit ' ' carriage-control when compiled with -DOMIT_BLANK_CC . Off-by-one bug fixed in character count for list output of character strings. Omit '.' in list-directed printing of Nan, Infinity. */ /* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather than " .0000E+00". */ /* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an oversize item to an empty line. */ /* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept ERR= (in list- or format-directed input) from working after a NAMELIST READ. */ /* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 in NAMELISTs. */ /* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ /* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ /* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when GOOD_SPRINTF_EXPONENT is not #defined. */ /* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow internal reading of characters with high-bit set (on machines that sign-extend characters). */ /* 14 March 1995:lread.c and rsfe.c: adjust s_rsle and s_rsfe to check for end-of-file (to prevent infinite loops with empty read statements). */ /* 26 May 1995: iio.c: z_wnew: fix bug in handling T format items in internal writes whose last item is written to an earlier position than some previous item. */ /* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ /* 6 Sept. 1995: Adjust namelist input to treat a subscripted name whose subscripts do not involve colons similarly to the name without a subscript: accept several values, stored in successive elements starting at the indicated subscript. Adjust namelist output to quote character strings (avoiding confusion with arrays of character strings). Adjust f_init calls for people who don't use libF77's main(); now open and namelist read statements invoke f_init if needed. */ /* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). Add -DNo_Namelist_Comments lines to rsne.c. */ /* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not always zeroed in mv_cur). */ /* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c to err.c */ /* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ /* 13 May 1996: add ftell_.c and fseek_.c */ /* 9 June 1996: Adjust rsli.c and lread.c so internal list input with too few items in the input string will honor end= . */ /* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ /* 25 Sept. 1995:fmt.h: for formatted writes of negative integer*1 values, make ic signed on ANSI systems. If formatted writes of integer*1 values trouble you when using a K&R C compiler, switch to an ANSI compiler or use a compiler flag that makes characters signed. */ /* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= in direct read and write statements. ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ /* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ /* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats (but still treat missing ".nnn" as ".0"). */ /* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather than fully buffered. (Buffering is needed for format items T and TR.) */ /* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be treated as 2 on some systems). */ /* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X draft (in 1990 or 1991) that rescinded permission to elide quote marks in namelist input of character data; compile with -DF8X_NML_ELIDE_QUOTES to get the old behavior. wrtfmt.o: wrt_G: tweak to print the right number of 0's for zero under G format. */ /* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character strings that sometimes caused one more array element than required by the format to be blank-filled. Example: format(1x). */ /* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines with 64-bit pointers and 32-bit ints that did not 64-bit align struct syl (e.g., Linux on the DEC Alpha). */ /* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to sizeof(uiolen). On machines where this would make a difference, it is best for portability to compile libI77 with -DUIOLEN_int (which will render the change invisible). */ /* 4 March 1998: open.c: fix glitch in comparing file names under -DNON_UNIX_STDIO */ /* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(), unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). New buffering scheme independent of NON_UNIX_STDIO for handling T format items. Now -DNON_UNIX_STDIO is no longer be necessary for Linux, and libf2c no longer causes stderr to be buffered -- the former setbuf or setvbuf call for stderr was to make T format items work. open.c: use the Posix access() function to check existence or nonexistence of files, except under -DNON_POSIX_STDIO, where trial fopen calls are used. */ /* 5 April 1998: wsfe.c: make $ format item work: this was lost in the changes of 17 March 1998. */ /* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: set f__curunit sooner so various error messages will correctly identify the I/O unit involved. */ /* 17 June 1998: lread.c: unless compiled with ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat floating-point numbers (containing either a decimal point or an exponent field) as errors when they appear as list input for integer data. */ /* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally. Why did it ever move to sfe.c? */ /* 2 May 1999: open.c: set f__external (to get "external" versus "internal" right in the error message if we cannot open the file). err.c: cast a pointer difference to (int) for %d. rdfmt.c: omit fixed-length buffer that could be overwritten by formats Inn or Lnn with nn > 83. */ /* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */ /* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */ /* 27 June 1999: rsne.c: fix bug in namelist input: a misplaced increment */ /* could cause wrong array elements to be assigned; e.g., */ /* "&input k(5)=10*1 &end" assigned k(5) and k(15..23) */ /* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */ /* endfile statement requires copying the file. */ /* (Otherwise an immediately following rewind statement */ /* could make the file appear empty.) Also, supply a */ /* missing (long) cast in the sprintf call. */ /* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */ /* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */ /* any data in buffers should the program fault. It also */ /* makes the program run more slowly. */ /* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */ /* ftnlen are of different fundamental types (different numbers */ /* of bits). Since these files will not compile when this */ /* change matters, the above VERSION string remains unchanged. */ /* 4 July 2000: adjustments to permit compilation by C++ compilers; */ /* VERSION string remains unchanged. */ /* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */ /* treat Tstuff= and Fstuff= as new assignments rather than as */ /* logical constants. */ /* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */ /* -DNO_TRUNCATE (or with -DMSDOS). */ /* 1 March 2001: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), */ /* thus permitting truncation of scratch files on true Unix */ /* systems, where scratch files have no name. Add an fflush() */ /* (surprisingly) needed on some Linux systems. */ /* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */ /* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */ /* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */ /* respectively, in fio.h unless otherwise #defined), and use */ /* type OFF_T (#defined to be long unless otherwise #defined) */ /* to permit handling files over 2GB long where possible, */ /* with suitable -D options, provided for some systems in new */ /* header file sysdep1.h (copied from sysdep1.h0 by default). */ /* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */ /* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */ /* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */ /* comments in makefile or (better) libf2c/makefile.* . */ /* 6 Sept. 2002: rsne.c: fix bug with multiple repeat counts in reading */ /* namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / */ /* 21 March 2003: err.c: before writing to a file after reading from it, */ /* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */ libf2c2-20090411.orig/i_abs.c0000644000175000017500000000032611236375625014144 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers integer i_abs(x) integer *x; #else integer i_abs(integer *x) #endif { if(*x >= 0) return(*x); return(- *x); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i_dim.c0000644000175000017500000000034111236375625014145 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i_dnnt.c0000644000175000017500000000044311236375625014342 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); integer i_dnnt(x) doublereal *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif integer i_dnnt(doublereal *x) #endif { return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i_indx.c0000644000175000017500000000065611236375625014347 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i_len.c0000644000175000017500000000031311236375625014151 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers integer i_len(s, n) char *s; ftnlen n; #else integer i_len(char *s, ftnlen n) #endif { return(n); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i_mod.c0000644000175000017500000000032311236375625014153 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers integer i_mod(a,b) integer *a, *b; #else integer i_mod(integer *a, integer *b) #endif { return( *a % *b); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i_nint.c0000644000175000017500000000042611236375625014350 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); integer i_nint(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif integer i_nint(real *x) #endif { return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/i_sign.c0000644000175000017500000000040411236375625014334 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/iargc_.c0000644000175000017500000000030411236375625014307 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers ftnint iargc_() #else ftnint iargc_(void) #endif { extern int xargc; return ( xargc - 1 ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/iio.c0000644000175000017500000000511711236375625013652 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "fmt.h" #ifdef __cplusplus extern "C" { #endif extern char *f__icptr; char *f__icend; extern icilist *f__svic; int f__icnum; int z_getc(Void) { if(f__recpos++ < f__svic->icirlen) { if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); return(*(unsigned char *)f__icptr++); } return '\n'; } void #ifdef KR_headers z_putc(c) #else z_putc(int c) #endif { if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen) *f__icptr++ = c; } int z_rnew(Void) { f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; f__recpos = 0; f__cursor = 0; f__hiwater = 0; return 1; } static int z_endp(Void) { (*f__donewrec)(); return 0; } int #ifdef KR_headers c_si(a) icilist *a; #else c_si(icilist *a) #endif { f__elist = (cilist *)a; f__fmtbuf=a->icifmt; f__curunit = 0; f__sequential=f__formatted=1; f__external=0; if(pars_f(f__fmtbuf)<0) err(a->icierr,100,"startint"); fmt_bg(); f__cblank=f__cplus=f__scale=0; f__svic=a; f__icnum=f__recpos=0; f__cursor = 0; f__hiwater = 0; f__icptr = a->iciunit; f__icend = f__icptr + a->icirlen*a->icirnum; f__cf = 0; return(0); } int iw_rev(Void) { if(f__workdone) z_endp(); f__hiwater = f__recpos = f__cursor = 0; return(f__workdone=0); } #ifdef KR_headers integer s_rsfi(a) icilist *a; #else integer s_rsfi(icilist *a) #endif { int n; if(n=c_si(a)) return(n); f__reading=1; f__doed=rd_ed; f__doned=rd_ned; f__getn=z_getc; f__dorevert = z_endp; f__donewrec = z_rnew; f__doend = z_endp; return(0); } int z_wnew(Void) { if (f__recpos < f__hiwater) { f__icptr += f__hiwater - f__recpos; f__recpos = f__hiwater; } while(f__recpos++ < f__svic->icirlen) *f__icptr++ = ' '; f__recpos = 0; f__cursor = 0; f__hiwater = 0; f__icnum++; return 1; } #ifdef KR_headers integer s_wsfi(a) icilist *a; #else integer s_wsfi(icilist *a) #endif { int n; if(n=c_si(a)) return(n); f__reading=0; f__doed=w_ed; f__doned=w_ned; f__putn=z_putc; f__dorevert = iw_rev; f__donewrec = z_wnew; f__doend = z_endp; return(0); } integer e_rsfi(Void) { int n = en_fio(); f__fmtbuf = NULL; return(n); } integer e_wsfi(Void) { int n; n = en_fio(); f__fmtbuf = NULL; if(f__svic->icirnum != 1 && (f__icnum > f__svic->icirnum || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) err(f__svic->icierr,110,"inwrite"); if (f__recpos < f__hiwater) f__recpos = f__hiwater; if (f__recpos >= f__svic->icirlen) err(f__svic->icierr,110,"recend"); if (!f__recpos && f__icnum) return n; while(f__recpos++ < f__svic->icirlen) *f__icptr++ = ' '; return n; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/ilnw.c0000644000175000017500000000214511236375625014041 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "lio.h" #ifdef __cplusplus extern "C" { #endif extern char *f__icptr; extern char *f__icend; extern icilist *f__svic; extern int f__icnum; #ifdef KR_headers extern void z_putc(); #else extern void z_putc(int); #endif static int z_wSL(Void) { while(f__recpos < f__svic->icirlen) z_putc(' '); return z_rnew(); } static void #ifdef KR_headers c_liw(a) icilist *a; #else c_liw(icilist *a) #endif { f__reading = 0; f__external = 0; f__formatted = 1; f__putn = z_putc; L_len = a->icirlen; f__donewrec = z_wSL; f__svic = a; f__icnum = f__recpos = 0; f__cursor = 0; f__cf = 0; f__curunit = 0; f__icptr = a->iciunit; f__icend = f__icptr + a->icirlen*a->icirnum; f__elist = (cilist *)a; } integer #ifdef KR_headers s_wsni(a) icilist *a; #else s_wsni(icilist *a) #endif { cilist ca; c_liw(a); ca.cifmt = a->icifmt; x_wsne(&ca); z_wSL(); return 0; } integer #ifdef KR_headers s_wsli(a) icilist *a; #else s_wsli(icilist *a) #endif { f__lioproc = l_write; c_liw(a); return(0); } integer e_wsli(Void) { z_wSL(); return(0); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/inquire.c0000644000175000017500000000525411236375625014550 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "string.h" #ifdef NON_UNIX_STDIO #ifndef MSDOS #include "unistd.h" /* for access() */ #endif #endif #ifdef KR_headers integer f_inqu(a) inlist *a; #else #ifdef __cplusplus extern "C" integer f_inqu(inlist*); #endif #ifdef MSDOS #undef abs #undef min #undef max #include "io.h" #endif integer f_inqu(inlist *a) #endif { flag byfile; int i; #ifndef NON_UNIX_STDIO int n; #endif unit *p; char buf[256]; long x; if(a->infile!=NULL) { byfile=1; g_char(a->infile,a->infilen,buf); #ifdef NON_UNIX_STDIO x = access(buf,0) ? -1 : 0; for(i=0,p=NULL;iinunitinunit>=0) { p= &f__units[a->inunit]; } else { p=NULL; } } if(a->inex!=NULL) if(byfile && x != -1 || !byfile && p!=NULL) *a->inex=1; else *a->inex=0; if(a->inopen!=NULL) if(byfile) *a->inopen=(p!=NULL); else *a->inopen=(p!=NULL && p->ufd!=NULL); if(a->innum!=NULL) *a->innum= p-f__units; if(a->innamed!=NULL) if(byfile || p!=NULL && p->ufnm!=NULL) *a->innamed=1; else *a->innamed=0; if(a->inname!=NULL) if(byfile) b_char(buf,a->inname,a->innamlen); else if(p!=NULL && p->ufnm!=NULL) b_char(p->ufnm,a->inname,a->innamlen); if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) if(p->url) b_char("DIRECT",a->inacc,a->inacclen); else b_char("SEQUENTIAL",a->inacc,a->inacclen); if(a->inseq!=NULL) if(p!=NULL && p->url) b_char("NO",a->inseq,a->inseqlen); else b_char("YES",a->inseq,a->inseqlen); if(a->indir!=NULL) if(p==NULL || p->url) b_char("YES",a->indir,a->indirlen); else b_char("NO",a->indir,a->indirlen); if(a->infmt!=NULL) if(p!=NULL && p->ufmt==0) b_char("UNFORMATTED",a->infmt,a->infmtlen); else b_char("FORMATTED",a->infmt,a->infmtlen); if(a->inform!=NULL) if(p!=NULL && p->ufmt==0) b_char("NO",a->inform,a->informlen); else b_char("YES",a->inform,a->informlen); if(a->inunf) if(p!=NULL && p->ufmt==0) b_char("YES",a->inunf,a->inunflen); else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); else b_char("UNKNOWN",a->inunf,a->inunflen); if(a->inrecl!=NULL && p!=NULL) *a->inrecl=p->url; if(a->innrec!=NULL && p!=NULL && p->url>0) *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1); if(a->inblank && p!=NULL && p->ufmt) if(p->ublnk) b_char("ZERO",a->inblank,a->inblanklen); else b_char("NULL",a->inblank,a->inblanklen); return(0); } libf2c2-20090411.orig/l_ge.c0000644000175000017500000000051611236375625013776 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/l_gt.c0000644000175000017500000000051511236375625014014 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/l_le.c0000644000175000017500000000051611236375625014003 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/l_lt.c0000644000175000017500000000051511236375625014021 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/lbitbits.c0000644000175000017500000000211111236375625014675 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/lbitshft.c0000644000175000017500000000040211236375625014701 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif 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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/libf2c.lbc0000644000175000017500000000307211236375625014547 0ustar afrb2afrb2abort_.obj backspac.obj c_abs.obj c_cos.obj c_div.obj c_exp.obj c_log.obj c_sin.obj c_sqrt.obj cabs.obj close.obj d_abs.obj d_acos.obj d_asin.obj d_atan.obj d_atn2.obj d_cnjg.obj d_cos.obj d_cosh.obj d_dim.obj d_exp.obj d_imag.obj d_int.obj d_lg10.obj d_log.obj d_mod.obj d_nint.obj d_prod.obj d_sign.obj d_sin.obj d_sinh.obj d_sqrt.obj d_tan.obj d_tanh.obj derf_.obj derfc_.obj dfe.obj dolio.obj dtime_.obj due.obj ef1asc_.obj ef1cmc_.obj endfile.obj erf_.obj erfc_.obj err.obj etime_.obj exit_.obj f77_aloc.obj f77vers.obj fmt.obj fmtlib.obj ftell_.obj getarg_.obj getenv_.obj h_abs.obj h_dim.obj h_dnnt.obj h_indx.obj h_len.obj h_mod.obj h_nint.obj h_sign.obj hl_ge.obj hl_gt.obj hl_le.obj hl_lt.obj i77vers.obj i_abs.obj i_dim.obj i_dnnt.obj i_indx.obj i_len.obj i_mod.obj i_nint.obj i_sign.obj iargc_.obj iio.obj ilnw.obj inquire.obj l_ge.obj l_gt.obj l_le.obj l_lt.obj lbitbits.obj lbitshft.obj lread.obj lwrite.obj main.obj open.obj pow_ci.obj pow_dd.obj pow_di.obj pow_hh.obj pow_ii.obj pow_ri.obj pow_zi.obj pow_zz.obj r_abs.obj r_acos.obj r_asin.obj r_atan.obj r_atn2.obj r_cnjg.obj r_cos.obj r_cosh.obj r_dim.obj r_exp.obj r_imag.obj r_int.obj r_lg10.obj r_log.obj r_mod.obj r_nint.obj r_sign.obj r_sin.obj r_sinh.obj r_sqrt.obj r_tan.obj r_tanh.obj rdfmt.obj rewind.obj rsfe.obj rsli.obj rsne.obj s_cat.obj s_cmp.obj s_copy.obj s_paus.obj s_rnge.obj s_stop.obj sfe.obj sig_die.obj signal_.obj sue.obj system_.obj typesize.obj uio.obj uninit.obj util.obj wref.obj wrtfmt.obj wsfe.obj wsle.obj wsne.obj xwsne.obj z_abs.obj z_cos.obj z_div.obj z_exp.obj z_log.obj z_sin.obj z_sqrt.obj libf2c2-20090411.orig/libf2c.sy0000644000175000017500000000400311236375625014435 0ustar afrb2afrb2+abort_.obj & +backspac.obj & +c_abs.obj & +c_cos.obj & +c_div.obj & +c_exp.obj & +c_log.obj & +c_sin.obj & +c_sqrt.obj & +cabs.obj & +close.obj & +d_abs.obj & +d_acos.obj & +d_asin.obj & +d_atan.obj & +d_atn2.obj & +d_cnjg.obj & +d_cos.obj & +d_cosh.obj & +d_dim.obj & +d_exp.obj & +d_imag.obj & +d_int.obj & +d_lg10.obj & +d_log.obj & +d_mod.obj & +d_nint.obj & +d_prod.obj & +d_sign.obj & +d_sin.obj & +d_sinh.obj & +d_sqrt.obj & +d_tan.obj & +d_tanh.obj & +derf_.obj & +derfc_.obj & +dfe.obj & +dolio.obj & +dtime_.obj & +due.obj & +ef1asc_.obj & +ef1cmc_.obj & +endfile.obj & +erf_.obj & +erfc_.obj & +err.obj & +etime_.obj & +exit_.obj & +f77_aloc.obj & +f77vers.obj & +fmt.obj & +fmtlib.obj & +ftell_.obj & +getarg_.obj & +getenv_.obj & +h_abs.obj & +h_dim.obj & +h_dnnt.obj & +h_indx.obj & +h_len.obj & +h_mod.obj & +h_nint.obj & +h_sign.obj & +hl_ge.obj & +hl_gt.obj & +hl_le.obj & +hl_lt.obj & +i77vers.obj & +i_abs.obj & +i_dim.obj & +i_dnnt.obj & +i_indx.obj & +i_len.obj & +i_mod.obj & +i_nint.obj & +i_sign.obj & +iargc_.obj & +iio.obj & +ilnw.obj & +inquire.obj & +l_ge.obj & +l_gt.obj & +l_le.obj & +l_lt.obj & +lbitbits.obj & +lbitshft.obj & +lread.obj & +lwrite.obj & +main.obj & +open.obj & +pow_ci.obj & +pow_dd.obj & +pow_di.obj & +pow_hh.obj & +pow_ii.obj & +pow_ri.obj & +pow_zi.obj & +pow_zz.obj & +r_abs.obj & +r_acos.obj & +r_asin.obj & +r_atan.obj & +r_atn2.obj & +r_cnjg.obj & +r_cos.obj & +r_cosh.obj & +r_dim.obj & +r_exp.obj & +r_imag.obj & +r_int.obj & +r_lg10.obj & +r_log.obj & +r_mod.obj & +r_nint.obj & +r_sign.obj & +r_sin.obj & +r_sinh.obj & +r_sqrt.obj & +r_tan.obj & +r_tanh.obj & +rdfmt.obj & +rewind.obj & +rsfe.obj & +rsli.obj & +rsne.obj & +s_cat.obj & +s_cmp.obj & +s_copy.obj & +s_paus.obj & +s_rnge.obj & +s_stop.obj & +sfe.obj & +sig_die.obj & +signal_.obj & +sue.obj & +system_.obj & +typesize.obj & +uio.obj & +uninit.obj & +util.obj & +wref.obj & +wrtfmt.obj & +wsfe.obj & +wsle.obj & +wsne.obj & +xwsne.obj & +z_abs.obj & +z_cos.obj & +z_div.obj & +z_exp.obj & +z_log.obj & +z_sin.obj & +z_sqrt.obj libf2c2-20090411.orig/lio.h0000644000175000017500000000303411236375625013656 0ustar afrb2afrb2/* copy of ftypes from the compiler */ /* variable types * numeric assumptions: * int < reals < complexes * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX */ /* 0-10 retain their old (pre LOGICAL*1, etc.) */ /* values to allow mixing old and new objects. */ #define TYUNKNOWN 0 #define TYADDR 1 #define TYSHORT 2 #define TYLONG 3 #define TYREAL 4 #define TYDREAL 5 #define TYCOMPLEX 6 #define TYDCOMPLEX 7 #define TYLOGICAL 8 #define TYCHAR 9 #define TYSUBR 10 #define TYINT1 11 #define TYLOGICAL1 12 #define TYLOGICAL2 13 #ifdef Allow_TYQUAD #undef TYQUAD #define TYQUAD 14 #endif #define LINTW 24 #define LINE 80 #define LLOGW 2 #ifdef Old_list_output #define LLOW 1.0 #define LHIGH 1.e9 #define LEFMT " %# .8E" #define LFFMT " %# .9g" #else #define LGFMT "%.9G" #endif /* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ #define LEFBL 24 typedef union { char flchar; short flshort; ftnint flint; #ifdef Allow_TYQUAD longint fllongint; #endif real flreal; doublereal fldouble; } flex; #ifdef KR_headers extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); extern int l_read(), l_write(); #else #ifdef __cplusplus extern "C" { #endif extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); extern int l_write(ftnint*, char*, ftnlen, ftnint); extern void x_wsne(cilist*); extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); extern int l_read(ftnint*,char*,ftnlen,ftnint); extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); extern int z_rnew(void); #endif extern ftnint L_len; extern int f__scale; #ifdef __cplusplus } #endif libf2c2-20090411.orig/lread.c0000644000175000017500000003462311236375625014165 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ /* marks in namelist input a la the Fortran 8X Draft published in */ /* the May 1989 issue of Fortran Forum. */ #ifdef Allow_TYQUAD static longint f__llx; #endif #ifdef KR_headers extern double atof(); extern char *malloc(), *realloc(); int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); #else #undef abs #undef min #undef max #include "stdlib.h" #endif #include "fmt.h" #include "lio.h" #include "ctype.h" #include "fp.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers extern char *f__fmtbuf; #else extern const char *f__fmtbuf; int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), (*l_ungetc)(int,FILE*); #endif int l_eof; #define isblnk(x) (f__ltab[x+1]&B) #define issep(x) (f__ltab[x+1]&SX) #define isapos(x) (f__ltab[x+1]&AX) #define isexp(x) (f__ltab[x+1]&EX) #define issign(x) (f__ltab[x+1]&SG) #define iswhit(x) (f__ltab[x+1]&WH) #define SX 1 #define B 2 #define AX 4 #define EX 8 #define SG 16 #define WH 32 char f__ltab[128+1] = { /* offset one for EOF */ 0, 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 }; #ifdef ungetc static int #ifdef KR_headers un_getc(x,f__cf) int x; FILE *f__cf; #else un_getc(int x, FILE *f__cf) #endif { return ungetc(x,f__cf); } #else #define un_getc ungetc #ifdef KR_headers extern int ungetc(); #else extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ #endif #endif int t_getc(Void) { int ch; if(f__curunit->uend) return(EOF); if((ch=getc(f__cf))!=EOF) return(ch); if(feof(f__cf)) f__curunit->uend = l_eof = 1; return(EOF); } integer e_rsle(Void) { int ch; if(f__curunit->uend) return(0); while((ch=t_getc())!='\n') if (ch == EOF) { if(feof(f__cf)) f__curunit->uend = l_eof = 1; return EOF; } return(0); } flag f__lquit; int f__lcount,f__ltype,nml_read; char *f__lchar; double f__lx,f__ly; #define ERR(x) if(n=(x)) return(n) #define GETC(x) (x=(*l_getc)()) #define Ungetc(x,y) (*l_ungetc)(x,y) static int #ifdef KR_headers l_R(poststar, reqint) int poststar, reqint; #else l_R(int poststar, int reqint) #endif { char s[FMAX+EXPMAXDIGS+4]; register int ch; register char *sp, *spe, *sp1; long e, exp; int havenum, havestar, se; if (!poststar) { if (f__lcount > 0) return(0); f__lcount = 1; } #ifdef Allow_TYQUAD f__llx = 0; #endif f__ltype = 0; exp = 0; havestar = 0; retry: sp1 = sp = s; spe = sp + FMAX; havenum = 0; switch(GETC(ch)) { case '-': *sp++ = ch; sp1++; spe++; case '+': GETC(ch); } while(ch == '0') { ++havenum; GETC(ch); } while(isdigit(ch)) { if (sp < spe) *sp++ = ch; else ++exp; GETC(ch); } if (ch == '*' && !poststar) { if (sp == sp1 || exp || *s == '-') { errfl(f__elist->cierr,112,"bad repetition count"); } poststar = havestar = 1; *sp = 0; f__lcount = atoi(s); goto retry; } if (ch == '.') { #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT if (reqint) errfl(f__elist->cierr,115,"invalid integer"); #endif GETC(ch); if (sp == sp1) while(ch == '0') { ++havenum; --exp; GETC(ch); } while(isdigit(ch)) { if (sp < spe) { *sp++ = ch; --exp; } GETC(ch); } } havenum += sp - sp1; se = 0; if (issign(ch)) goto signonly; if (havenum && isexp(ch)) { #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT if (reqint) errfl(f__elist->cierr,115,"invalid integer"); #endif GETC(ch); if (issign(ch)) { signonly: if (ch == '-') se = 1; GETC(ch); } if (!isdigit(ch)) { bad: errfl(f__elist->cierr,112,"exponent field"); } e = ch - '0'; while(isdigit(GETC(ch))) { e = 10*e + ch - '0'; if (e > EXPMAX) goto bad; } if (se) exp -= e; else exp += e; } (void) Ungetc(ch, f__cf); if (sp > sp1) { ++havenum; while(*--sp == '0') ++exp; if (exp) sprintf(sp+1, "e%ld", exp); else sp[1] = 0; f__lx = atof(s); #ifdef Allow_TYQUAD if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { /* Assuming 64-bit longint and 32-bit long. */ if (exp < 0) sp += exp; if (sp1 <= sp) { f__llx = *sp1 - '0'; while(++sp1 <= sp) f__llx = 10*f__llx + (*sp1 - '0'); } while(--exp >= 0) f__llx *= 10; if (*s == '-') f__llx = -f__llx; } #endif } else f__lx = 0.; if (havenum) f__ltype = TYLONG; else switch(ch) { case ',': case '/': break; default: if (havestar && ( ch == ' ' ||ch == '\t' ||ch == '\n')) break; if (nml_read > 1) { f__lquit = 2; return 0; } errfl(f__elist->cierr,112,"invalid number"); } return 0; } static int #ifdef KR_headers rd_count(ch) register int ch; #else rd_count(register int ch) #endif { if (ch < '0' || ch > '9') return 1; f__lcount = ch - '0'; while(GETC(ch) >= '0' && ch <= '9') f__lcount = 10*f__lcount + ch - '0'; Ungetc(ch,f__cf); return f__lcount <= 0; } static int l_C(Void) { int ch, nml_save; double lz; if(f__lcount>0) return(0); f__ltype=0; GETC(ch); if(ch!='(') { if (nml_read > 1 && (ch < '0' || ch > '9')) { Ungetc(ch,f__cf); f__lquit = 2; return 0; } if (rd_count(ch)) if(!f__cf || !feof(f__cf)) errfl(f__elist->cierr,112,"complex format"); else err(f__elist->cierr,(EOF),"lread"); if(GETC(ch)!='*') { if(!f__cf || !feof(f__cf)) errfl(f__elist->cierr,112,"no star"); else err(f__elist->cierr,(EOF),"lread"); } if(GETC(ch)!='(') { Ungetc(ch,f__cf); return(0); } } else f__lcount = 1; while(iswhit(GETC(ch))); Ungetc(ch,f__cf); nml_save = nml_read; nml_read = 0; if (ch = l_R(1,0)) return ch; if (!f__ltype) errfl(f__elist->cierr,112,"no real part"); lz = f__lx; while(iswhit(GETC(ch))); if(ch!=',') { (void) Ungetc(ch,f__cf); errfl(f__elist->cierr,112,"no comma"); } while(iswhit(GETC(ch))); (void) Ungetc(ch,f__cf); if (ch = l_R(1,0)) return ch; if (!f__ltype) errfl(f__elist->cierr,112,"no imaginary part"); while(iswhit(GETC(ch))); if(ch!=')') errfl(f__elist->cierr,112,"no )"); f__ly = f__lx; f__lx = lz; #ifdef Allow_TYQUAD f__llx = 0; #endif nml_read = nml_save; return(0); } static char nmLbuf[256], *nmL_next; static int (*nmL_getc_save)(Void); #ifdef KR_headers static int (*nmL_ungetc_save)(/* int, FILE* */); #else static int (*nmL_ungetc_save)(int, FILE*); #endif static int nmL_getc(Void) { int rv; if (rv = *nmL_next++) return rv; l_getc = nmL_getc_save; l_ungetc = nmL_ungetc_save; return (*l_getc)(); } static int #ifdef KR_headers nmL_ungetc(x, f) int x; FILE *f; #else nmL_ungetc(int x, FILE *f) #endif { f = f; /* banish non-use warning */ return *--nmL_next = x; } static int #ifdef KR_headers Lfinish(ch, dot, rvp) int ch, dot, *rvp; #else Lfinish(int ch, int dot, int *rvp) #endif { char *s, *se; static char what[] = "namelist input"; s = nmLbuf + 2; se = nmLbuf + sizeof(nmLbuf) - 1; *s++ = ch; while(!issep(GETC(ch)) && ch!=EOF) { if (s >= se) { nmLbuf_ovfl: return *rvp = err__fl(f__elist->cierr,131,what); } *s++ = ch; if (ch != '=') continue; if (dot) return *rvp = err__fl(f__elist->cierr,112,what); got_eq: *s = 0; nmL_getc_save = l_getc; l_getc = nmL_getc; nmL_ungetc_save = l_ungetc; l_ungetc = nmL_ungetc; nmLbuf[1] = *(nmL_next = nmLbuf) = ','; *rvp = f__lcount = 0; return 1; } if (dot) goto done; for(;;) { if (s >= se) goto nmLbuf_ovfl; *s++ = ch; if (!isblnk(ch)) break; if (GETC(ch) == EOF) goto done; } if (ch == '=') goto got_eq; done: Ungetc(ch, f__cf); return 0; } static int l_L(Void) { int ch, rv, sawdot; if(f__lcount>0) return(0); f__lcount = 1; f__ltype=0; GETC(ch); if(isdigit(ch)) { rd_count(ch); if(GETC(ch)!='*') if(!f__cf || !feof(f__cf)) errfl(f__elist->cierr,112,"no star"); else err(f__elist->cierr,(EOF),"lread"); GETC(ch); } sawdot = 0; if(ch == '.') { sawdot = 1; GETC(ch); } switch(ch) { case 't': case 'T': if (nml_read && Lfinish(ch, sawdot, &rv)) return rv; f__lx=1; break; case 'f': case 'F': if (nml_read && Lfinish(ch, sawdot, &rv)) return rv; f__lx=0; break; default: if(isblnk(ch) || issep(ch) || ch==EOF) { (void) Ungetc(ch,f__cf); return(0); } if (nml_read > 1) { Ungetc(ch,f__cf); f__lquit = 2; return 0; } errfl(f__elist->cierr,112,"logical"); } f__ltype=TYLONG; while(!issep(GETC(ch)) && ch!=EOF); Ungetc(ch, f__cf); return(0); } #define BUFSIZE 128 static int l_CHAR(Void) { int ch,size,i; static char rafail[] = "realloc failure"; char quote,*p; if(f__lcount>0) return(0); f__ltype=0; if(f__lchar!=NULL) free(f__lchar); size=BUFSIZE; p=f__lchar = (char *)malloc((unsigned int)size); if(f__lchar == NULL) errfl(f__elist->cierr,113,"no space"); GETC(ch); if(isdigit(ch)) { /* allow Fortran 8x-style unquoted string... */ /* either find a repetition count or the string */ f__lcount = ch - '0'; *p++ = ch; for(i = 1;;) { switch(GETC(ch)) { case '*': if (f__lcount == 0) { f__lcount = 1; #ifndef F8X_NML_ELIDE_QUOTES if (nml_read) goto no_quote; #endif goto noquote; } p = f__lchar; goto have_lcount; case ',': case ' ': case '\t': case '\n': case '/': Ungetc(ch,f__cf); /* no break */ case EOF: f__lcount = 1; f__ltype = TYCHAR; return *p = 0; } if (!isdigit(ch)) { f__lcount = 1; #ifndef F8X_NML_ELIDE_QUOTES if (nml_read) { no_quote: errfl(f__elist->cierr,112, "undelimited character string"); } #endif goto noquote; } *p++ = ch; f__lcount = 10*f__lcount + ch - '0'; if (++i == size) { f__lchar = (char *)realloc(f__lchar, (unsigned int)(size += BUFSIZE)); if(f__lchar == NULL) errfl(f__elist->cierr,113,rafail); p = f__lchar + i; } } } else (void) Ungetc(ch,f__cf); have_lcount: if(GETC(ch)=='\'' || ch=='"') quote=ch; else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { Ungetc(ch,f__cf); return 0; } #ifndef F8X_NML_ELIDE_QUOTES else if (nml_read > 1) { Ungetc(ch,f__cf); f__lquit = 2; return 0; } #endif else { /* Fortran 8x-style unquoted string */ *p++ = ch; for(i = 1;;) { switch(GETC(ch)) { case ',': case ' ': case '\t': case '\n': case '/': Ungetc(ch,f__cf); /* no break */ case EOF: f__ltype = TYCHAR; return *p = 0; } noquote: *p++ = ch; if (++i == size) { f__lchar = (char *)realloc(f__lchar, (unsigned int)(size += BUFSIZE)); if(f__lchar == NULL) errfl(f__elist->cierr,113,rafail); p = f__lchar + i; } } } f__ltype=TYCHAR; for(i=0;;) { while(GETC(ch)!=quote && ch!='\n' && ch!=EOF && ++icierr,113,rafail); p=f__lchar+i-1; *p++ = ch; } else if(ch==EOF) return(EOF); else if(ch=='\n') { if(*(p-1) != '\\') continue; i--; p--; if(++iciunit]; if(a->ciunit>=MXUNIT || a->ciunit<0) err(a->cierr,101,"stler"); f__scale=f__recpos=0; f__elist=a; if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,102,"lio"); f__cf=f__curunit->ufd; if(!f__curunit->ufmt) err(a->cierr,103,"lio") return(0); } int #ifdef KR_headers l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; #else l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) #endif { #define Ptr ((flex *)ptr) int i,n,ch; doublereal *yy; real *xx; for(i=0;i<*number;i++) { if(f__lquit) return(0); if(l_eof) err(f__elist->ciend, EOF, "list in") if(f__lcount == 0) { f__ltype = 0; for(;;) { GETC(ch); switch(ch) { case EOF: err(f__elist->ciend,(EOF),"list in") case ' ': case '\t': case '\n': continue; case '/': f__lquit = 1; goto loopend; case ',': f__lcount = 1; goto loopend; default: (void) Ungetc(ch, f__cf); goto rddata; } } } rddata: switch((int)type) { case TYINT1: case TYSHORT: case TYLONG: #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT ERR(l_R(0,1)); break; #endif case TYREAL: case TYDREAL: ERR(l_R(0,0)); break; #ifdef TYQUAD case TYQUAD: n = l_R(0,2); if (n) return n; break; #endif case TYCOMPLEX: case TYDCOMPLEX: ERR(l_C()); break; case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: ERR(l_L()); break; case TYCHAR: ERR(l_CHAR()); break; } while (GETC(ch) == ' ' || ch == '\t'); if (ch != ',' || f__lcount > 1) Ungetc(ch,f__cf); loopend: if(f__lquit) return(0); if(f__cf && ferror(f__cf)) { clearerr(f__cf); errfl(f__elist->cierr,errno,"list in"); } if(f__ltype==0) goto bump; switch((int)type) { case TYINT1: case TYLOGICAL1: Ptr->flchar = (char)f__lx; break; case TYLOGICAL2: case TYSHORT: Ptr->flshort = (short)f__lx; break; case TYLOGICAL: case TYLONG: Ptr->flint = (ftnint)f__lx; break; #ifdef Allow_TYQUAD case TYQUAD: if (!(Ptr->fllongint = f__llx)) Ptr->fllongint = f__lx; break; #endif case TYREAL: Ptr->flreal=f__lx; break; case TYDREAL: Ptr->fldouble=f__lx; break; case TYCOMPLEX: xx=(real *)ptr; *xx++ = f__lx; *xx = f__ly; break; case TYDCOMPLEX: yy=(doublereal *)ptr; *yy++ = f__lx; *yy = f__ly; break; case TYCHAR: b_char(f__lchar,ptr,len); break; } bump: if(f__lcount>0) f__lcount--; ptr += len; if (nml_read) nml_read++; } return(0); #undef Ptr } #ifdef KR_headers integer s_rsle(a) cilist *a; #else integer s_rsle(cilist *a) #endif { int n; f__reading=1; f__external=1; f__formatted=1; if(n=c_le(a)) return(n); f__lioproc = l_read; f__lquit = 0; f__lcount = 0; l_eof = 0; if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr,errno,"read start"); if(f__curunit->uend) err(f__elist->ciend,(EOF),"read start"); l_getc = t_getc; l_ungetc = un_getc; f__doend = xrd_SL; return(0); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/lwrite.c0000644000175000017500000001101011236375625014365 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "fmt.h" #include "lio.h" #ifdef __cplusplus extern "C" { #endif ftnint L_len; int f__Aquote; static VOID donewrec(Void) { if (f__recpos) (*f__donewrec)(); } static VOID #ifdef KR_headers lwrt_I(n) longint n; #else lwrt_I(longint n) #endif { char *p; int ndigit, sign; p = f__icvt(n, &ndigit, &sign, 10); if(f__recpos + ndigit >= L_len) donewrec(); PUT(' '); if (sign) PUT('-'); while(*p) PUT(*p++); } static VOID #ifdef KR_headers lwrt_L(n, len) ftnint n; ftnlen len; #else lwrt_L(ftnint n, ftnlen len) #endif { if(f__recpos+LLOGW>=L_len) donewrec(); wrt_L((Uint *)&n,LLOGW, len); } static VOID #ifdef KR_headers lwrt_A(p,len) char *p; ftnlen len; #else lwrt_A(char *p, ftnlen len) #endif { int a; char *p1, *pe; a = 0; pe = p + len; if (f__Aquote) { a = 3; if (len > 1 && p[len-1] == ' ') { while(--len > 1 && p[len-1] == ' '); pe = p + len; } p1 = p; while(p1 < pe) if (*p1++ == '\'') a++; } if(f__recpos+len+a >= L_len) donewrec(); if (a #ifndef OMIT_BLANK_CC || !f__recpos #endif ) PUT(' '); if (a) { PUT('\''); while(p < pe) { if (*p == '\'') PUT('\''); PUT(*p++); } PUT('\''); } else while(p < pe) PUT(*p++); } static int #ifdef KR_headers l_g(buf, n) char *buf; double n; #else l_g(char *buf, double n) #endif { #ifdef Old_list_output doublereal absn; char *fmt; absn = n; if (absn < 0) absn = -absn; fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; #ifdef USE_STRLEN sprintf(buf, fmt, n); return strlen(buf); #else return sprintf(buf, fmt, n); #endif #else register char *b, c, c1; b = buf; *b++ = ' '; if (n < 0) { *b++ = '-'; n = -n; } else *b++ = ' '; if (n == 0) { #ifdef SIGNED_ZEROS if (signbit_f2c(&n)) *b++ = '-'; #endif *b++ = '0'; *b++ = '.'; *b = 0; goto f__ret; } sprintf(b, LGFMT, n); switch(*b) { #ifndef WANT_LEAD_0 case '0': while(b[0] = b[1]) b++; break; #endif case 'i': case 'I': /* Infinity */ case 'n': case 'N': /* NaN */ while(*++b); break; default: /* Fortran 77 insists on having a decimal point... */ for(;; b++) switch(*b) { case 0: *b++ = '.'; *b = 0; goto f__ret; case '.': while(*++b); goto f__ret; case 'E': for(c1 = '.', c = 'E'; *b = c1; c1 = c, c = *++b); goto f__ret; } } f__ret: return b - buf; #endif } static VOID #ifdef KR_headers l_put(s) register char *s; #else l_put(register char *s) #endif { #ifdef KR_headers register void (*pn)() = f__putn; #else register void (*pn)(int) = f__putn; #endif register int c; while(c = *s++) (*pn)(c); } static VOID #ifdef KR_headers lwrt_F(n) double n; #else lwrt_F(double n) #endif { char buf[LEFBL]; if(f__recpos + l_g(buf,n) >= L_len) donewrec(); l_put(buf); } static VOID #ifdef KR_headers lwrt_C(a,b) double a,b; #else lwrt_C(double a, double b) #endif { char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; int al, bl; al = l_g(bufa, a); for(ba = bufa; *ba == ' '; ba++) --al; bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ for(bb = bufb; *bb == ' '; bb++) --bl; if(f__recpos + al + bl + 3 >= L_len) donewrec(); #ifdef OMIT_BLANK_CC else #endif PUT(' '); PUT('('); l_put(ba); PUT(','); if (f__recpos + bl >= L_len) { (*f__donewrec)(); #ifndef OMIT_BLANK_CC PUT(' '); #endif } l_put(bb); PUT(')'); } int #ifdef KR_headers l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; #else l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) #endif { #define Ptr ((flex *)ptr) int i; longint x; double y,z; real *xx; doublereal *yy; for(i=0;i< *number; i++) { switch((int)type) { default: f__fatal(117,"unknown type in lio"); case TYINT1: x = Ptr->flchar; goto xint; case TYSHORT: x=Ptr->flshort; goto xint; #ifdef Allow_TYQUAD case TYQUAD: x = Ptr->fllongint; goto xint; #endif case TYLONG: x=Ptr->flint; xint: lwrt_I(x); break; case TYREAL: y=Ptr->flreal; goto xfloat; case TYDREAL: y=Ptr->fldouble; xfloat: lwrt_F(y); break; case TYCOMPLEX: xx= &Ptr->flreal; y = *xx++; z = *xx; goto xcomplex; case TYDCOMPLEX: yy = &Ptr->fldouble; y= *yy++; z = *yy; xcomplex: lwrt_C(y,z); break; case TYLOGICAL1: x = Ptr->flchar; goto xlog; case TYLOGICAL2: x = Ptr->flshort; goto xlog; case TYLOGICAL: x = Ptr->flint; xlog: lwrt_L(Ptr->flint, len); break; case TYCHAR: lwrt_A(ptr,len); break; } ptr += len; } return(0); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/main.c0000644000175000017500000000426611236375625014022 0ustar afrb2afrb2/* 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" #ifdef __cplusplus extern "C" { #endif #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(const char*, int); extern int MAIN__(void); #define Int int #endif static VOID sigfdie(Sigarg) { Use_Sigarg; sig_die("Floating Exception", 1); } static VOID sigidie(Sigarg) { Use_Sigarg; sig_die("IOT Trap", 1); } #ifdef SIGQUIT static VOID sigqdie(Sigarg) { Use_Sigarg; sig_die("Quit signal", 1); } #endif static VOID sigindie(Sigarg) { Use_Sigarg; sig_die("Interrupt", 0); } static VOID sigtdie(Sigarg) { Use_Sigarg; sig_die("Killed", 0); } #ifdef SIGTRAP static VOID sigtrdie(Sigarg) { Use_Sigarg; sig_die("Trace trap", 1); } #endif int xargc; char **xargv; #ifdef __cplusplus } #endif int #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. */ } #ifdef __cplusplus } #endif libf2c2-20090411.orig/makefile.sy0000644000175000017500000000565611236375625015070 0ustar afrb2afrb2# For making f2c.lib (here called syf2c.lib) with Symantec C++ . # Invoke with "make -f makefile.sy" . # In the CFLAGS line below, "-mn" is for NT and W9x. # For 32-bit addressing with MSDOS, change "-mn" to "-mx". # With Symantec, it is necessary to explicitly load main.obj . # To get signed zeros in write statements on IEEE-arithmetic systems, # add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj # to the objects in the "w =" list below. CC = sc CFLAGS = -DMSDOS -D_POSIX_SOURCE -DNO_ONEXIT -s -mn -DUSE_CLOCK -DNO_My_ctype .c.obj: $(CC) -c $(CFLAGS) $*.c w = \ abort_.obj \ backspac.obj \ c_abs.obj \ c_cos.obj \ c_div.obj \ c_exp.obj \ c_log.obj \ c_sin.obj \ c_sqrt.obj \ cabs.obj \ close.obj \ d_abs.obj \ d_acos.obj \ d_asin.obj \ d_atan.obj \ d_atn2.obj \ d_cnjg.obj \ d_cos.obj \ d_cosh.obj \ d_dim.obj \ d_exp.obj \ d_imag.obj \ d_int.obj \ d_lg10.obj \ d_log.obj \ d_mod.obj \ d_nint.obj \ d_prod.obj \ d_sign.obj \ d_sin.obj \ d_sinh.obj \ d_sqrt.obj \ d_tan.obj \ d_tanh.obj \ derf_.obj \ derfc_.obj \ dfe.obj \ dolio.obj \ dtime_.obj \ due.obj \ ef1asc_.obj \ ef1cmc_.obj \ endfile.obj \ erf_.obj \ erfc_.obj \ err.obj \ etime_.obj \ exit_.obj \ f77_aloc.obj \ f77vers.obj \ fmt.obj \ fmtlib.obj \ ftell_.obj \ getarg_.obj \ getenv_.obj \ h_abs.obj \ h_dim.obj \ h_dnnt.obj \ h_indx.obj \ h_len.obj \ h_mod.obj \ h_nint.obj \ h_sign.obj \ hl_ge.obj \ hl_gt.obj \ hl_le.obj \ hl_lt.obj \ i77vers.obj \ i_abs.obj \ i_dim.obj \ i_dnnt.obj \ i_indx.obj \ i_len.obj \ i_mod.obj \ i_nint.obj \ i_sign.obj \ iargc_.obj \ iio.obj \ ilnw.obj \ inquire.obj \ l_ge.obj \ l_gt.obj \ l_le.obj \ l_lt.obj \ lbitbits.obj \ lbitshft.obj \ lread.obj \ lwrite.obj \ main.obj \ open.obj \ pow_ci.obj \ pow_dd.obj \ pow_di.obj \ pow_hh.obj \ pow_ii.obj \ pow_ri.obj \ pow_zi.obj \ pow_zz.obj \ r_abs.obj \ r_acos.obj \ r_asin.obj \ r_atan.obj \ r_atn2.obj \ r_cnjg.obj \ r_cos.obj \ r_cosh.obj \ r_dim.obj \ r_exp.obj \ r_imag.obj \ r_int.obj \ r_lg10.obj \ r_log.obj \ r_mod.obj \ r_nint.obj \ r_sign.obj \ r_sin.obj \ r_sinh.obj \ r_sqrt.obj \ r_tan.obj \ r_tanh.obj \ rdfmt.obj \ rewind.obj \ rsfe.obj \ rsli.obj \ rsne.obj \ s_cat.obj \ s_cmp.obj \ s_copy.obj \ s_paus.obj \ s_rnge.obj \ s_stop.obj \ sfe.obj \ sig_die.obj \ signal_.obj \ sue.obj \ system_.obj \ typesize.obj \ uio.obj \ util.obj \ uninit.obj \ wref.obj \ wrtfmt.obj \ wsfe.obj \ wsle.obj \ wsne.obj \ xwsne.obj \ z_abs.obj \ z_cos.obj \ z_div.obj \ z_exp.obj \ z_log.obj \ z_sin.obj \ z_sqrt.obj syf2c.lib: f2c.h signal1.h sysdep1.h $w lib /B /C syf2c.lib @libf2c.sy f2c.h: f2c.h0 copy f2c.h0 f2c.h signal1.h: signal1.h0 copy signal1.h0 signal1.h sysdep1.h: sysdep1.h0 copy sysdep1.h0 sysdep1.h signbit.obj uninit.obj: arith.h arith.h: arithchk.c scomptry.bat $(CC) $(CFLAGS) arithchk.c arithchk del arithchk.exe del arithchk.obj libf2c2-20090411.orig/makefile.u0000644000175000017500000001632311236376510014664 0ustar afrb2afrb2# Unix makefile: see README. # For C++, first "make hadd". # If your compiler does not recognize ANSI C, add # -DKR_headers # to the CFLAGS = line below. # On Sun and other BSD systems that do not provide an ANSI sprintf, add # -DUSE_STRLEN # to the CFLAGS = line below. # On Linux systems, add # -DNON_UNIX_STDIO # to the CFLAGS = line below. For libf2c.so under Linux, also add # -fPIC # to the CFLAGS = line below. .SUFFIXES: .c .o CC = cc SHELL = /bin/sh CFLAGS = -O # 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 = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\ getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o ctype.o\ derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.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\ lbitbits.o lbitshft.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 I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\ fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\ open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\ typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o TIME = dtime_.o etime_.o # 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 OFILES = assignment below. # To get signed zeros in write statements on IEEE-arithmetic systems, # add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.o # to the end of the OFILES = assignment below. # For INTEGER*8 support (which requires system-dependent adjustments to # f2c.h), add $(QINT) to the OFILES = assignment below... OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME) all: f2c.h signal1.h sysdep1.h libf2c.a libf2c.a: $(OFILES) ar r libf2c.a $? -ranlib libf2c.a ## Shared-library variant: the following rule works on Linux ## systems. Details are system-dependent. Under Linux, -fPIC ## must appear in the CFLAGS assignment when making libf2c.so. ## Under Solaris, use -Kpic in CFLAGS and use "ld -G" instead ## of "$(CC) -shared". ## For MacOSX 10.4 and 10.5 (and perhaps other versions >= 10.3), use ## "MACOSX_DEPLOYMENT_TARGET=10.3 libtool -dynamic -undefined dynamic_lookup -single_module" ## instead of "$(CC) -shared", and when running programs linked against libf2c.so, ## arrange for $DYLD_LIBRARY_PATH to include the directory containing libf2c.so. libf2c.so: $(OFILES) $(CC) -shared -o libf2c.so $(OFILES) ### If your system lacks ranlib, you don't need it; see README. f77vers.o: f77vers.c $(CC) -c f77vers.c i77vers.o: i77vers.c $(CC) -c i77vers.c # To get an "f2c.h" for use with "f2c -C++", first "make hadd" hadd: f2c.h0 f2ch.add cat f2c.h0 f2ch.add >f2c.h # For use with "f2c" and "f2c -A": f2c.h: f2c.h0 cp f2c.h0 f2c.h # You may need to adjust signal1.h and sysdep1.h suitably for your system... signal1.h: signal1.h0 cp signal1.h0 signal1.h sysdep1.h: sysdep1.h0 cp sysdep1.h0 sysdep1.h # If your system lacks onexit() and you are not using an # ANSI C compiler, then you should uncomment the following # two lines (for compiling main.o): #main.o: main.c # $(CC) -c -DNO_ONEXIT -DSkip_f2c_Undefs main.c # On at least some Sun systems, it is more appropriate to # uncomment the following two lines: #main.o: main.c # $(CC) -c -Donexit=on_exit -DSkip_f2c_Undefs main.c install: libf2c.a cp libf2c.a $(LIBDIR) -ranlib $(LIBDIR)/libf2c.a clean: rm -f libf2c.a *.o arith.h signal1.h sysdep1.h backspac.o: fio.h close.o: fio.h dfe.o: fio.h dfe.o: fmt.h due.o: fio.h endfile.o: fio.h rawio.h err.o: fio.h rawio.h fmt.o: fio.h fmt.o: fmt.h iio.o: fio.h iio.o: fmt.h ilnw.o: fio.h ilnw.o: lio.h inquire.o: fio.h lread.o: fio.h lread.o: fmt.h lread.o: lio.h lread.o: fp.h lwrite.o: fio.h lwrite.o: fmt.h lwrite.o: lio.h open.o: fio.h rawio.h rdfmt.o: fio.h rdfmt.o: fmt.h rdfmt.o: fp.h rewind.o: fio.h rsfe.o: fio.h rsfe.o: fmt.h rsli.o: fio.h rsli.o: lio.h rsne.o: fio.h rsne.o: lio.h sfe.o: fio.h signbit.o: arith.h sue.o: fio.h uio.o: fio.h uninit.o: arith.h util.o: fio.h wref.o: fio.h wref.o: fmt.h wref.o: fp.h wrtfmt.o: fio.h wrtfmt.o: fmt.h wsfe.o: fio.h wsfe.o: fmt.h wsle.o: fio.h wsle.o: fmt.h wsle.o: lio.h wsne.o: fio.h wsne.o: lio.h xwsne.o: fio.h xwsne.o: lio.h xwsne.o: fmt.h arith.h: arithchk.c $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\ $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm ./a.out >arith.h rm -f a.out arithchk.o check: xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \ c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \ ctype.c ctype.h \ 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 dfe.c dolio.c dtime_.c due.c ef1asc_.c \ ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \ f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \ fp.h ftell_.c ftell64_.c \ 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 \ i77vers.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 iio.c ilnw.c inquire.c l_ge.c l_gt.c \ l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \ lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \ makefile.wat math.hvc mkfile.plan9 open.c 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 rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \ s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c scomptry.bat sfe.c \ sig_die.c signal1.h0 signal_.c signbit.c sue.c sysdep1.h0 system_.c \ typesize.c \ uio.c uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \ z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out libf2c2-20090411.orig/makefile.vc0000644000175000017500000000561211236376510015027 0ustar afrb2afrb2# For making f2c.lib (here called vcf2c.lib) with Microsoft Visual C++ . # Invoke with "nmake -f makefile.vc" . # To get signed zeros in write statements on IEEE-arithmetic systems, # add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj # to the objects in the "w =" list below. CC = cl CFLAGS = -DUSE_CLOCK -DMSDOS -DNO_ONEXIT -Ot1 -DNO_My_ctype -DNO_ISATTY .c.obj: $(CC) -c $(CFLAGS) $*.c w = \ abort_.obj \ backspac.obj \ c_abs.obj \ c_cos.obj \ c_div.obj \ c_exp.obj \ c_log.obj \ c_sin.obj \ c_sqrt.obj \ cabs.obj \ close.obj \ d_abs.obj \ d_acos.obj \ d_asin.obj \ d_atan.obj \ d_atn2.obj \ d_cnjg.obj \ d_cos.obj \ d_cosh.obj \ d_dim.obj \ d_exp.obj \ d_imag.obj \ d_int.obj \ d_lg10.obj \ d_log.obj \ d_mod.obj \ d_nint.obj \ d_prod.obj \ d_sign.obj \ d_sin.obj \ d_sinh.obj \ d_sqrt.obj \ d_tan.obj \ d_tanh.obj \ derf_.obj \ derfc_.obj \ dfe.obj \ dolio.obj \ dtime_.obj \ due.obj \ ef1asc_.obj \ ef1cmc_.obj \ endfile.obj \ erf_.obj \ erfc_.obj \ err.obj \ etime_.obj \ exit_.obj \ f77_aloc.obj \ f77vers.obj \ fmt.obj \ fmtlib.obj \ ftell_.obj \ getarg_.obj \ getenv_.obj \ h_abs.obj \ h_dim.obj \ h_dnnt.obj \ h_indx.obj \ h_len.obj \ h_mod.obj \ h_nint.obj \ h_sign.obj \ hl_ge.obj \ hl_gt.obj \ hl_le.obj \ hl_lt.obj \ i77vers.obj \ i_abs.obj \ i_dim.obj \ i_dnnt.obj \ i_indx.obj \ i_len.obj \ i_mod.obj \ i_nint.obj \ i_sign.obj \ iargc_.obj \ iio.obj \ ilnw.obj \ inquire.obj \ l_ge.obj \ l_gt.obj \ l_le.obj \ l_lt.obj \ lbitbits.obj \ lbitshft.obj \ lread.obj \ lwrite.obj \ main.obj \ open.obj \ pow_ci.obj \ pow_dd.obj \ pow_di.obj \ pow_hh.obj \ pow_ii.obj \ pow_ri.obj \ pow_zi.obj \ pow_zz.obj \ r_abs.obj \ r_acos.obj \ r_asin.obj \ r_atan.obj \ r_atn2.obj \ r_cnjg.obj \ r_cos.obj \ r_cosh.obj \ r_dim.obj \ r_exp.obj \ r_imag.obj \ r_int.obj \ r_lg10.obj \ r_log.obj \ r_mod.obj \ r_nint.obj \ r_sign.obj \ r_sin.obj \ r_sinh.obj \ r_sqrt.obj \ r_tan.obj \ r_tanh.obj \ rdfmt.obj \ rewind.obj \ rsfe.obj \ rsli.obj \ rsne.obj \ s_cat.obj \ s_cmp.obj \ s_copy.obj \ s_paus.obj \ s_rnge.obj \ s_stop.obj \ sfe.obj \ sig_die.obj \ signal_.obj \ sue.obj \ system_.obj \ typesize.obj \ uio.obj \ uninit.obj \ util.obj \ wref.obj \ wrtfmt.obj \ wsfe.obj \ wsle.obj \ wsne.obj \ xwsne.obj \ z_abs.obj \ z_cos.obj \ z_div.obj \ z_exp.obj \ z_log.obj \ z_sin.obj \ z_sqrt.obj all: f2c.h math.h signal1.h sysdep1.h vcf2c.lib f2c.h: f2c.h0 copy f2c.h0 f2c.h math.h: math.hvc copy math.hvc math.h signal1.h: signal1.h0 copy signal1.h0 signal1.h sysdep1.h: sysdep1.h0 copy sysdep1.h0 sysdep1.h vcf2c.lib: $w lib -out:vcf2c.lib @libf2c.lbc open.obj: open.c $(CC) -c $(CFLAGS) -DMSDOS open.c signbit.obj uninit.obj: arith.h arith.h: arithchk.c comptry.bat $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c arithchk >arith.h del arithchk.exe del arithchk.obj libf2c2-20090411.orig/makefile.wat0000644000175000017500000000557011236375625015223 0ustar afrb2afrb2# For making f2c.lib (here called watf2c.lib) with WATCOM C/C++ . # Invoke with "wmake -u -f makefile.wat" . # In the CFLAGS line below, "-bt=nt" is for NT and W9x. # With WATCOM, it is necessary to explicitly load main.obj . # To get signed zeros in write statements on IEEE-arithmetic systems, # add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj # to the objects in the "w =" list below. CC = wcc386 CFLAGS = -fpd -DMSDOS -DUSE_CLOCK -DNO_ONEXIT -bt=nt -DNO_My_ctype .c.obj: $(CC) $(CFLAGS) $*.c w = \ abort_.obj \ backspac.obj \ c_abs.obj \ c_cos.obj \ c_div.obj \ c_exp.obj \ c_log.obj \ c_sin.obj \ c_sqrt.obj \ cabs.obj \ close.obj \ d_abs.obj \ d_acos.obj \ d_asin.obj \ d_atan.obj \ d_atn2.obj \ d_cnjg.obj \ d_cos.obj \ d_cosh.obj \ d_dim.obj \ d_exp.obj \ d_imag.obj \ d_int.obj \ d_lg10.obj \ d_log.obj \ d_mod.obj \ d_nint.obj \ d_prod.obj \ d_sign.obj \ d_sin.obj \ d_sinh.obj \ d_sqrt.obj \ d_tan.obj \ d_tanh.obj \ derf_.obj \ derfc_.obj \ dfe.obj \ dolio.obj \ dtime_.obj \ due.obj \ ef1asc_.obj \ ef1cmc_.obj \ endfile.obj \ erf_.obj \ erfc_.obj \ err.obj \ etime_.obj \ exit_.obj \ f77_aloc.obj \ f77vers.obj \ fmt.obj \ fmtlib.obj \ ftell_.obj \ getarg_.obj \ getenv_.obj \ h_abs.obj \ h_dim.obj \ h_dnnt.obj \ h_indx.obj \ h_len.obj \ h_mod.obj \ h_nint.obj \ h_sign.obj \ hl_ge.obj \ hl_gt.obj \ hl_le.obj \ hl_lt.obj \ i77vers.obj \ i_abs.obj \ i_dim.obj \ i_dnnt.obj \ i_indx.obj \ i_len.obj \ i_mod.obj \ i_nint.obj \ i_sign.obj \ iargc_.obj \ iio.obj \ ilnw.obj \ inquire.obj \ l_ge.obj \ l_gt.obj \ l_le.obj \ l_lt.obj \ lbitbits.obj \ lbitshft.obj \ lread.obj \ lwrite.obj \ main.obj \ open.obj \ pow_ci.obj \ pow_dd.obj \ pow_di.obj \ pow_hh.obj \ pow_ii.obj \ pow_ri.obj \ pow_zi.obj \ pow_zz.obj \ r_abs.obj \ r_acos.obj \ r_asin.obj \ r_atan.obj \ r_atn2.obj \ r_cnjg.obj \ r_cos.obj \ r_cosh.obj \ r_dim.obj \ r_exp.obj \ r_imag.obj \ r_int.obj \ r_lg10.obj \ r_log.obj \ r_mod.obj \ r_nint.obj \ r_sign.obj \ r_sin.obj \ r_sinh.obj \ r_sqrt.obj \ r_tan.obj \ r_tanh.obj \ rdfmt.obj \ rewind.obj \ rsfe.obj \ rsli.obj \ rsne.obj \ s_cat.obj \ s_cmp.obj \ s_copy.obj \ s_paus.obj \ s_rnge.obj \ s_stop.obj \ sfe.obj \ sig_die.obj \ signal_.obj \ sue.obj \ system_.obj \ typesize.obj \ uio.obj \ uninit.obj \ util.obj \ wref.obj \ wrtfmt.obj \ wsfe.obj \ wsle.obj \ wsne.obj \ xwsne.obj \ z_abs.obj \ z_cos.obj \ z_div.obj \ z_exp.obj \ z_log.obj \ z_sin.obj \ z_sqrt.obj watf2c.lib: f2c.h signal1.h sysdep1.h $w wlib -c watf2c.lib @libf2c f2c.h: f2c.h0 copy f2c.h0 f2c.h signal1.h: signal1.h0 copy signal1.h0 signal1.h sysdep1.h: sysdep1.h0 copy sysdep1.h0 sysdep1.h signbit.obj uninit.obj: arith.h arith.h: arithchk.c comptry.bat wcl386 -DNO_FPINIT arithchk.c arithchk >arith.h del arithchk.exe del arithchk.obj libf2c2-20090411.orig/math.hvc0000644000175000017500000000006211236375625014353 0ustar afrb2afrb2/* for VC 4.2 */ #include #undef complex libf2c2-20090411.orig/mkfile.plan90000644000175000017500000001206611236375625015143 0ustar afrb2afrb2# Plan 9 mkfile for libf2c.a$O f2c.h # For use with "f2c" and "f2c -A": f2c.h: f2c.h0 cp f2c.h0 f2c.h # You may need to adjust signal1.h suitably for your system... signal1.h: signal1.h0 cp signal1.h0 signal1.h clean: rm -f libf2c.a$O *.$O arith.h backspac.$O: fio.h close.$O: fio.h dfe.$O: fio.h dfe.$O: fmt.h due.$O: fio.h endfile.$O: fio.h rawio.h err.$O: fio.h rawio.h fmt.$O: fio.h fmt.$O: fmt.h iio.$O: fio.h iio.$O: fmt.h ilnw.$O: fio.h ilnw.$O: lio.h inquire.$O: fio.h lread.$O: fio.h lread.$O: fmt.h lread.$O: lio.h lread.$O: fp.h lwrite.$O: fio.h lwrite.$O: fmt.h lwrite.$O: lio.h open.$O: fio.h rawio.h rdfmt.$O: fio.h rdfmt.$O: fmt.h rdfmt.$O: fp.h rewind.$O: fio.h rsfe.$O: fio.h rsfe.$O: fmt.h rsli.$O: fio.h rsli.$O: lio.h rsne.$O: fio.h rsne.$O: lio.h sfe.$O: fio.h sue.$O: fio.h uio.$O: fio.h uninit.$O: arith.h util.$O: fio.h wref.$O: fio.h wref.$O: fmt.h wref.$O: fp.h wrtfmt.$O: fio.h wrtfmt.$O: fmt.h wsfe.$O: fio.h wsfe.$O: fmt.h wsle.$O: fio.h wsle.$O: fmt.h wsle.$O: lio.h wsne.$O: fio.h wsne.$O: lio.h xwsne.$O: fio.h xwsne.$O: lio.h xwsne.$O: fmt.h arith.h: arithchk.c pcc -DNO_FPINIT -o arithchk arithchk.c arithchk >$target rm arithchk xsum.out:V: check check: xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \ c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \ 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 dfe.c dolio.c dtime_.c due.c ef1asc_.c \ ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \ f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \ fp.h ftell_.c \ 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 \ i77vers.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 iio.c ilnw.c inquire.c l_ge.c l_gt.c \ l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \ lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \ makefile.wat math.hvc mkfile.plan9 open.c 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 rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \ s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c sfe.c \ sig_die.c signal1.h0 signal_.c sue.c system_.c typesize.c uio.c \ uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \ z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out libf2c2-20090411.orig/open.c0000644000175000017500000001310511236375625014027 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "string.h" #ifndef NON_POSIX_STDIO #ifdef MSDOS #include "io.h" #else #include "unistd.h" /* for access */ #endif #endif #ifdef KR_headers extern char *malloc(); #ifdef NON_ANSI_STDIO extern char *mktemp(); #endif extern integer f_clos(); #define Const /*nothing*/ #else #define Const const #undef abs #undef min #undef max #include "stdlib.h" #ifdef __cplusplus extern "C" { #endif extern int f__canseek(FILE*); extern integer f_clos(cllist*); #endif #ifdef NON_ANSI_RW_MODES Const char *f__r_mode[2] = {"r", "r"}; Const char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; #else Const char *f__r_mode[2] = {"rb", "r"}; Const char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; #endif static char f__buf0[400], *f__buf = f__buf0; int f__buflen = (int)sizeof(f__buf0); static void #ifdef KR_headers f__bufadj(n, c) int n, c; #else f__bufadj(int n, int c) #endif { unsigned int len; char *nbuf, *s, *t, *te; if (f__buf == f__buf0) f__buflen = 1024; while(f__buflen <= n) f__buflen <<= 1; len = (unsigned int)f__buflen; if (len != f__buflen || !(nbuf = (char*)malloc(len))) f__fatal(113, "malloc failure"); s = nbuf; t = f__buf; te = t + c; while(t < te) *s++ = *t++; if (f__buf != f__buf0) free(f__buf); f__buf = nbuf; } int #ifdef KR_headers f__putbuf(c) int c; #else f__putbuf(int c) #endif { char *s, *se; int n; if (f__hiwater > f__recpos) f__recpos = f__hiwater; n = f__recpos + 1; if (n >= f__buflen) f__bufadj(n, f__recpos); s = f__buf; se = s + f__recpos; if (c) *se++ = c; *se = 0; for(;;) { fputs(s, f__cf); s += strlen(s); if (s >= se) break; /* normally happens the first time */ putc(*s++, f__cf); } return 0; } void #ifdef KR_headers x_putc(c) #else x_putc(int c) #endif { if (f__recpos >= f__buflen) f__bufadj(f__recpos, f__buflen); f__buf[f__recpos++] = c; } #define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);} static void #ifdef KR_headers opn_err(m, s, a) int m; char *s; olist *a; #else opn_err(int m, const char *s, olist *a) #endif { if (a->ofnm) { /* supply file name to error message */ if (a->ofnmlen >= f__buflen) f__bufadj((int)a->ofnmlen, 0); g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); } f__fatal(m, s); } #ifdef KR_headers integer f_open(a) olist *a; #else integer f_open(olist *a) #endif { unit *b; integer rv; char buf[256], *s; cllist x; int ufmt; FILE *tf; #ifndef NON_UNIX_STDIO int n; #endif f__external = 1; if(a->ounit>=MXUNIT || a->ounit<0) err(a->oerr,101,"open") if (!f__init) f_init(); f__curunit = b = &f__units[a->ounit]; if(b->ufd) { if(a->ofnm==0) { same: if (a->oblnk) b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; return(0); } #ifdef NON_UNIX_STDIO if (b->ufnm && strlen(b->ufnm) == a->ofnmlen && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) goto same; #else g_char(a->ofnm,a->ofnmlen,buf); if (f__inode(buf,&n) == b->uinode && n == b->udev) goto same; #endif x.cunit=a->ounit; x.csta=0; x.cerr=a->oerr; if ((rv = f_clos(&x)) != 0) return rv; } b->url = (int)a->orl; b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); if(a->ofm==0) { if(b->url>0) b->ufmt=0; else b->ufmt=1; } else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; else b->ufmt=0; ufmt = b->ufmt; #ifdef url_Adjust if (b->url && !ufmt) url_Adjust(b->url); #endif if (a->ofnm) { g_char(a->ofnm,a->ofnmlen,buf); if (!buf[0]) opnerr(a->oerr,107,"open") } else sprintf(buf, "fort.%ld", (long)a->ounit); b->uscrtch = 0; b->uend=0; b->uwrt = 0; b->ufd = 0; b->urw = 3; switch(a->osta ? *a->osta : 'u') { case 'o': case 'O': #ifdef NON_POSIX_STDIO if (!(tf = FOPEN(buf,"r"))) opnerr(a->oerr,errno,"open") fclose(tf); #else if (access(buf,0)) opnerr(a->oerr,errno,"open") #endif break; case 's': case 'S': b->uscrtch=1; #ifdef NON_ANSI_STDIO (void) strcpy(buf,"tmp.FXXXXXX"); (void) mktemp(buf); goto replace; #else if (!(b->ufd = tmpfile())) opnerr(a->oerr,errno,"open") b->ufnm = 0; #ifndef NON_UNIX_STDIO b->uinode = b->udev = -1; #endif b->useek = 1; return 0; #endif case 'n': case 'N': #ifdef NON_POSIX_STDIO if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) { fclose(tf); opnerr(a->oerr,128,"open") } #else if (!access(buf,0)) opnerr(a->oerr,128,"open") #endif /* no break */ case 'r': /* Fortran 90 replace option */ case 'R': #ifdef NON_ANSI_STDIO replace: #endif if (tf = FOPEN(buf,f__w_mode[0])) fclose(tf); } b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); (void) strcpy(b->ufnm,buf); if ((s = a->oacc) && b->url) ufmt = 0; if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) { if (tf = FOPEN(buf, f__r_mode[ufmt])) b->urw = 1; else if (tf = FOPEN(buf, f__w_mode[ufmt])) { b->uwrt = 1; b->urw = 2; } else err(a->oerr, errno, "open"); } b->useek = f__canseek(b->ufd = tf); #ifndef NON_UNIX_STDIO if((b->uinode = f__inode(buf,&b->udev)) == -1) opnerr(a->oerr,108,"open") #endif if(b->useek) if (a->orl) rewind(b->ufd); else if ((s = a->oacc) && (*s == 'a' || *s == 'A') && FSEEK(b->ufd, 0L, SEEK_END)) opnerr(a->oerr,129,"open"); return(0); } int #ifdef KR_headers fk_open(seq,fmt,n) ftnint n; #else fk_open(int seq, int fmt, ftnint n) #endif { char nbuf[10]; olist a; (void) sprintf(nbuf,"fort.%ld",(long)n); a.oerr=1; a.ounit=n; a.ofnm=nbuf; a.ofnmlen=strlen(nbuf); a.osta=NULL; a.oacc= (char*)(seq==SEQ?"s":"d"); a.ofm = (char*)(fmt==FMT?"f":"u"); a.orl = seq==DIR?1:0; a.oblnk=NULL; return(f_open(&a)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_ci.c0000644000175000017500000000063411236375625014351 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_dd.c0000644000175000017500000000042411236375625014342 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double pow(); double pow_dd(ap, bp) doublereal *ap, *bp; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double pow_dd(doublereal *ap, doublereal *bp) #endif { return(pow(*ap, *bp) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_di.c0000644000175000017500000000070011236375625014344 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_hh.c0000644000175000017500000000075111236375625014355 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_ii.c0000644000175000017500000000075011236375625014356 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_qq.c0000644000175000017500000000100411236375625014367 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_ri.c0000644000175000017500000000066411236375625014373 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_zi.c0000644000175000017500000000152311236375625014376 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers VOID pow_zi(p, a, b) /* p = a**b */ doublecomplex *p, *a; integer *b; #else extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ #endif { integer n; unsigned long u; double t; doublecomplex q, x; static doublecomplex one = {1.0, 0.0}; n = *b; q.r = 1; q.i = 0; if(n == 0) goto done; if(n < 0) { n = -n; z_div(&x, &one, a); } else { x.r = a->r; x.i = a->i; } for(u = n; ; ) { if(u & 01) { t = q.r * x.r - q.i * x.i; q.i = q.r * x.i + q.i * x.r; q.r = t; } if(u >>= 1) { t = x.r * x.r - x.i * x.i; x.i = 2 * x.r * x.i; x.r = t; } else break; } done: p->i = q.i; p->r = q.r; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/pow_zz.c0000644000175000017500000000104511236375625014416 0ustar afrb2afrb2#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" #ifdef __cplusplus extern "C" { #endif 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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/qbitbits.c0000644000175000017500000000217711236375625014716 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifndef LONGBITS #define LONGBITS 32 #endif #ifndef LONG8BITS #define LONG8BITS (2*LONGBITS) #endif longint #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)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/qbitshft.c0000644000175000017500000000040211236375625014706 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif 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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_abs.c0000644000175000017500000000031611236375625014154 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers double r_abs(x) real *x; #else double r_abs(real *x) #endif { if(*x >= 0) return(*x); return(- *x); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_acos.c0000644000175000017500000000035111236375625014333 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double acos(); double r_acos(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_acos(real *x) #endif { return( acos(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_asin.c0000644000175000017500000000035111236375625014340 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double asin(); double r_asin(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_asin(real *x) #endif { return( asin(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_atan.c0000644000175000017500000000035111236375625014331 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double atan(); double r_atan(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_atan(real *x) #endif { return( atan(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_atn2.c0000644000175000017500000000037511236375625014260 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double atan2(); double r_atn2(x,y) real *x, *y; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_atn2(real *x, real *y) #endif { return( atan2(*x,*y) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_cnjg.c0000644000175000017500000000035311236375625014331 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers VOID r_cnjg(r, z) complex *r, *z; #else VOID r_cnjg(complex *r, complex *z) #endif { real zi = z->i; r->r = z->r; r->i = -zi; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_cos.c0000644000175000017500000000034511236375625014175 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double cos(); double r_cos(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_cos(real *x) #endif { return( cos(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_cosh.c0000644000175000017500000000035111236375625014342 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double cosh(); double r_cosh(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_cosh(real *x) #endif { return( cosh(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_dim.c0000644000175000017500000000032611236375625014161 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_exp.c0000644000175000017500000000034511236375625014205 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double exp(); double r_exp(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_exp(real *x) #endif { return( exp(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_imag.c0000644000175000017500000000027511236375625014330 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers double r_imag(z) complex *z; #else double r_imag(complex *z) #endif { return(z->i); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_int.c0000644000175000017500000000040111236375625014174 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); double r_int(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_int(real *x) #endif { return( (*x>0) ? floor(*x) : -floor(- *x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_lg10.c0000644000175000017500000000042711236375625014155 0ustar afrb2afrb2#include "f2c.h" #define log10e 0.43429448190325182765 #ifdef KR_headers double log(); double r_lg10(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_lg10(real *x) #endif { return( log10e * log(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_log.c0000644000175000017500000000034511236375625014172 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double log(); double r_log(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_log(real *x) #endif { return( log(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_mod.c0000644000175000017500000000124611236375625014171 0ustar afrb2afrb2#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" #ifdef __cplusplus extern "C" { #endif #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 } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_nint.c0000644000175000017500000000041511236375625014357 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double floor(); double r_nint(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_nint(real *x) #endif { return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_sign.c0000644000175000017500000000037011236375625014347 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_sin.c0000644000175000017500000000034511236375625014202 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sin(); double r_sin(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_sin(real *x) #endif { return( sin(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_sinh.c0000644000175000017500000000035111236375625014347 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sinh(); double r_sinh(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_sinh(real *x) #endif { return( sinh(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_sqrt.c0000644000175000017500000000035111236375625014377 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sqrt(); double r_sqrt(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_sqrt(real *x) #endif { return( sqrt(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_tan.c0000644000175000017500000000034511236375625014173 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double tan(); double r_tan(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_tan(real *x) #endif { return( tan(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/r_tanh.c0000644000175000017500000000035111236375625014340 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double tanh(); double r_tanh(x) real *x; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif double r_tanh(real *x) #endif { return( tanh(*x) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/rawio.h0000644000175000017500000000131611236375625014215 0ustar afrb2afrb2#ifndef KR_headers #ifdef MSDOS #include "io.h" #ifndef WATCOM #define close _close #define creat _creat #define open _open #define read _read #define write _write #endif /*WATCOM*/ #endif /*MSDOS*/ #ifdef __cplusplus extern "C" { #endif #ifndef MSDOS #ifdef OPEN_DECL extern int creat(const char*,int), open(const char*,int); #endif extern int close(int); extern int read(int,void*,size_t), write(int,void*,size_t); extern int unlink(const char*); #ifndef _POSIX_SOURCE #ifndef NON_UNIX_STDIO extern FILE *fdopen(int, const char*); #endif #endif #endif /*KR_HEADERS*/ extern char *mktemp(char*); #ifdef __cplusplus } #endif #endif #include "fcntl.h" #ifndef O_WRONLY #define O_RDONLY 0 #define O_WRONLY 1 #endif libf2c2-20090411.orig/rdfmt.c0000644000175000017500000002133511236375625014206 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef KR_headers extern double atof(); #define Const /*nothing*/ #else #define Const const #undef abs #undef min #undef max #include "stdlib.h" #endif #include "fmt.h" #include "fp.h" #include "ctype.h" #ifdef __cplusplus extern "C" { #endif static int #ifdef KR_headers rd_Z(n,w,len) Uint *n; ftnlen len; #else rd_Z(Uint *n, int w, ftnlen len) #endif { long x[9]; char *s, *s0, *s1, *se, *t; Const char *sc; int ch, i, w1, w2; static char hex[256]; static int one = 1; int bad = 0; if (!hex['0']) { sc = "0123456789"; while(ch = *sc++) hex[ch] = ch - '0' + 1; sc = "ABCDEF"; while(ch = *sc++) hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; } s = s0 = (char *)x; s1 = (char *)&x[4]; se = (char *)&x[8]; if (len > 4*sizeof(long)) return errno = 117; while (w) { GET(ch); if (ch==',' || ch=='\n') break; w--; if (ch > ' ') { if (!hex[ch & 0xff]) bad++; *s++ = ch; if (s == se) { /* discard excess characters */ for(t = s0, s = s1; t < s1;) *t++ = *s++; s = s1; } } } if (bad) return errno = 115; w = (int)len; w1 = s - s0; w2 = w1+1 >> 1; t = (char *)n; if (*(char *)&one) { /* little endian */ t += w - 1; i = -1; } else i = 1; for(; w > w2; t += i, --w) *t = 0; if (!w) return 0; if (w < w2) s0 = s - (w << 1); else if (w1 & 1) { *t = hex[*s0++ & 0xff] - 1; if (!--w) return 0; t += i; } do { *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; t += i; s0 += 2; } while(--w); return 0; } static int #ifdef KR_headers rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; #else rd_I(Uint *n, int w, ftnlen len, register int base) #endif { int ch, sign; longint x = 0; if (w <= 0) goto have_x; for(;;) { GET(ch); if (ch != ' ') break; if (!--w) goto have_x; } sign = 0; switch(ch) { case ',': case '\n': w = 0; goto have_x; case '-': sign = 1; case '+': break; default: if (ch >= '0' && ch <= '9') { x = ch - '0'; break; } goto have_x; } while(--w) { GET(ch); if (ch >= '0' && ch <= '9') { x = x*base + ch - '0'; continue; } if (ch != ' ') { if (ch == '\n' || ch == ',') w = 0; break; } if (f__cblank) x *= base; } if (sign) x = -x; have_x: if(len == sizeof(integer)) n->il=x; else if(len == sizeof(char)) n->ic = (char)x; #ifdef Allow_TYQUAD else if (len == sizeof(longint)) n->ili = x; #endif else n->is = (short)x; if (w) { while(--w) GET(ch); return errno = 115; } return 0; } static int #ifdef KR_headers rd_L(n,w,len) ftnint *n; ftnlen len; #else rd_L(ftnint *n, int w, ftnlen len) #endif { int ch, dot, lv; if (w <= 0) goto bad; for(;;) { GET(ch); --w; if (ch != ' ') break; if (!w) goto bad; } dot = 0; retry: switch(ch) { case '.': if (dot++ || !w) goto bad; GET(ch); --w; goto retry; case 't': case 'T': lv = 1; break; case 'f': case 'F': lv = 0; break; default: bad: for(; w > 0; --w) GET(ch); /* no break */ case ',': case '\n': return errno = 116; } switch(len) { case sizeof(char): *(char *)n = (char)lv; break; case sizeof(short): *(short *)n = (short)lv; break; default: *n = lv; } while(w-- > 0) { GET(ch); if (ch == ',' || ch == '\n') break; } return 0; } static int #ifdef KR_headers rd_F(p, w, d, len) ufloat *p; ftnlen len; #else rd_F(ufloat *p, int w, int d, ftnlen len) #endif { char s[FMAX+EXPMAXDIGS+4]; register int ch; register char *sp, *spe, *sp1; double x; int scale1, se; long e, exp; sp1 = sp = s; spe = sp + FMAX; exp = -d; x = 0.; do { GET(ch); w--; } while (ch == ' ' && w); switch(ch) { case '-': *sp++ = ch; sp1++; spe++; case '+': if (!w) goto zero; --w; GET(ch); } while(ch == ' ') { blankdrop: if (!w--) goto zero; GET(ch); } while(ch == '0') { if (!w--) goto zero; GET(ch); } if (ch == ' ' && f__cblank) goto blankdrop; scale1 = f__scale; while(isdigit(ch)) { digloop1: if (sp < spe) *sp++ = ch; else ++exp; digloop1e: if (!w--) goto done; GET(ch); } if (ch == ' ') { if (f__cblank) { ch = '0'; goto digloop1; } goto digloop1e; } if (ch == '.') { exp += d; if (!w--) goto done; GET(ch); if (sp == sp1) { /* no digits yet */ while(ch == '0') { skip01: --exp; skip0: if (!w--) goto done; GET(ch); } if (ch == ' ') { if (f__cblank) goto skip01; goto skip0; } } while(isdigit(ch)) { digloop2: if (sp < spe) { *sp++ = ch; --exp; } digloop2e: if (!w--) goto done; GET(ch); } if (ch == ' ') { if (f__cblank) { ch = '0'; goto digloop2; } goto digloop2e; } } switch(ch) { default: break; case '-': se = 1; goto signonly; case '+': se = 0; goto signonly; case 'e': case 'E': case 'd': case 'D': if (!w--) goto bad; GET(ch); while(ch == ' ') { if (!w--) goto bad; GET(ch); } se = 0; switch(ch) { case '-': se = 1; case '+': signonly: if (!w--) goto bad; GET(ch); } while(ch == ' ') { if (!w--) goto bad; GET(ch); } if (!isdigit(ch)) goto bad; e = ch - '0'; for(;;) { if (!w--) { ch = '\n'; break; } GET(ch); if (!isdigit(ch)) { if (ch == ' ') { if (f__cblank) ch = '0'; else continue; } else break; } e = 10*e + ch - '0'; if (e > EXPMAX && sp > sp1) goto bad; } if (se) exp -= e; else exp += e; scale1 = 0; } switch(ch) { case '\n': case ',': break; default: bad: return (errno = 115); } done: if (sp > sp1) { while(*--sp == '0') ++exp; if (exp -= scale1) sprintf(sp+1, "e%ld", exp); else sp[1] = 0; x = atof(s); } zero: if (len == sizeof(real)) p->pf = x; else p->pd = x; return(0); } static int #ifdef KR_headers rd_A(p,len) char *p; ftnlen len; #else rd_A(char *p, ftnlen len) #endif { int i,ch; for(i=0;i=len) { for(i=0;i0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); if(f__cursor<0) { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ f__cursor = -f__recpos; /* is this in the standard? */ if(f__external == 0) { extern char *f__icptr; f__icptr += f__cursor; } else if(f__curunit && f__curunit->useek) (void) FSEEK(f__cf, f__cursor,SEEK_CUR); else err(f__elist->cierr,106,"fmt"); f__recpos += f__cursor; f__cursor=0; } switch(p->op) { default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); sig_die(f__fmtbuf, 1); case IM: case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); break; /* O and OM don't work right for character, double, complex, */ /* or doublecomplex, and they differ from Fortran 90 in */ /* showing a minus sign for negative values. */ case OM: case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); break; case L: ch = rd_L((ftnint *)ptr,p->p1,len); break; case A: ch = rd_A(ptr,len); break; case AW: ch = rd_AW(ptr,p->p1,len); break; case E: case EE: case D: case G: case GE: case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); break; /* Z and ZM assume 8-bit bytes. */ case ZM: case Z: ch = rd_Z((Uint *)ptr, p->p1, len); break; } if(ch == 0) return(ch); else if(ch == EOF) return(EOF); if (f__cf) clearerr(f__cf); return(errno); } int #ifdef KR_headers rd_ned(p) struct syl *p; #else rd_ned(struct syl *p) #endif { switch(p->op) { default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); sig_die(f__fmtbuf, 1); case APOS: return(rd_POS(p->p2.s)); case H: return(rd_H(p->p1,p->p2.s)); case SLASH: return((*f__donewrec)()); case TR: case X: f__cursor += p->p1; return(1); case T: f__cursor=p->p1-f__recpos - 1; return(1); case TL: f__cursor -= p->p1; if(f__cursor < -f__recpos) /* TL1000, 1X */ f__cursor = -f__recpos; return(1); } } #ifdef __cplusplus } #endif libf2c2-20090411.orig/rewind.c0000644000175000017500000000073311236375625014361 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers integer f_rew(a) alist *a; #else integer f_rew(alist *a) #endif { unit *b; if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"rewind"); b = &f__units[a->aunit]; if(b->ufd == NULL || b->uwrt == 3) return(0); if(!b->useek) err(a->aerr,106,"rewind") if(b->uwrt) { (void) t_runc(a); b->uwrt = 3; } rewind(b->ufd); b->uend=0; return(0); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/rsfe.c0000644000175000017500000000272411236375625014032 0ustar afrb2afrb2/* read sequential formatted external */ #include "f2c.h" #include "fio.h" #include "fmt.h" #ifdef __cplusplus extern "C" { #endif int xrd_SL(Void) { int ch; if(!f__curunit->uend) while((ch=getc(f__cf))!='\n') if (ch == EOF) { f__curunit->uend = 1; break; } f__cursor=f__recpos=0; return(1); } int x_getc(Void) { int ch; if(f__curunit->uend) return(EOF); ch = getc(f__cf); if(ch!=EOF && ch!='\n') { f__recpos++; return(ch); } if(ch=='\n') { (void) ungetc(ch,f__cf); return(ch); } if(f__curunit->uend || feof(f__cf)) { errno=0; f__curunit->uend=1; return(-1); } return(-1); } int x_endp(Void) { xrd_SL(); return f__curunit->uend == 1 ? EOF : 0; } int x_rev(Void) { (void) xrd_SL(); return(0); } #ifdef KR_headers integer s_rsfe(a) cilist *a; /* start */ #else integer s_rsfe(cilist *a) /* start */ #endif { int n; if(!f__init) f_init(); f__reading=1; f__sequential=1; f__formatted=1; f__external=1; if(n=c_sfe(a)) return(n); f__elist=a; f__cursor=f__recpos=0; f__scale=0; f__fmtbuf=a->cifmt; f__cf=f__curunit->ufd; if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); f__getn= x_getc; f__doed= rd_ed; f__doned= rd_ned; fmt_bg(); f__doend=x_endp; f__donewrec=xrd_SL; f__dorevert=x_rev; f__cblank=f__curunit->ublnk; f__cplus=0; if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr,errno,"read start"); if(f__curunit->uend) err(f__elist->ciend,(EOF),"read start"); return(0); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/rsli.c0000644000175000017500000000337111236375625014043 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "lio.h" #include "fmt.h" /* for f__doend */ #ifdef __cplusplus extern "C" { #endif extern flag f__lquit; extern int f__lcount; extern char *f__icptr; extern char *f__icend; extern icilist *f__svic; extern int f__icnum, f__recpos; static int i_getc(Void) { if(f__recpos >= f__svic->icirlen) { if (f__recpos++ == f__svic->icirlen) return '\n'; z_rnew(); } f__recpos++; if(f__icptr >= f__icend) return EOF; return(*f__icptr++); } static #ifdef KR_headers int i_ungetc(ch, f) int ch; FILE *f; #else int i_ungetc(int ch, FILE *f) #endif { if (--f__recpos == f__svic->icirlen) return '\n'; if (f__recpos < -1) err(f__svic->icierr,110,"recend"); /* *--icptr == ch, and icptr may point to read-only memory */ return *--f__icptr /* = ch */; } static void #ifdef KR_headers c_lir(a) icilist *a; #else c_lir(icilist *a) #endif { extern int l_eof; f__reading = 1; f__external = 0; f__formatted = 1; f__svic = a; L_len = a->icirlen; f__recpos = -1; f__icnum = f__recpos = 0; f__cursor = 0; l_getc = i_getc; l_ungetc = i_ungetc; l_eof = 0; f__icptr = a->iciunit; f__icend = f__icptr + a->icirlen*a->icirnum; f__cf = 0; f__curunit = 0; f__elist = (cilist *)a; } #ifdef KR_headers integer s_rsli(a) icilist *a; #else integer s_rsli(icilist *a) #endif { f__lioproc = l_read; f__lquit = 0; f__lcount = 0; c_lir(a); f__doend = 0; return(0); } integer e_rsli(Void) { return 0; } #ifdef KR_headers integer s_rsni(a) icilist *a; #else extern int x_rsne(cilist*); integer s_rsni(icilist *a) #endif { extern int nml_read; integer rv; cilist ca; ca.ciend = a->iciend; ca.cierr = a->icierr; ca.cifmt = a->icifmt; c_lir(a); rv = x_rsne(&ca); nml_read = 0; return rv; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/rsne.c0000644000175000017500000002650111236375625014041 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "lio.h" #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ #define MAXDIM 20 /* maximum number of subscripts */ struct dimen { ftnlen extent; ftnlen curval; ftnlen delta; ftnlen stride; }; typedef struct dimen dimen; struct hashentry { struct hashentry *next; char *name; Vardesc *vd; }; typedef struct hashentry hashentry; struct hashtab { struct hashtab *next; Namelist *nl; int htsize; hashentry *tab[1]; }; typedef struct hashtab hashtab; static hashtab *nl_cache; static int n_nlcache; static hashentry **zot; static int colonseen; extern ftnlen f__typesize[]; extern flag f__lquit; extern int f__lcount, nml_read; extern int t_getc(Void); #ifdef KR_headers extern char *malloc(), *memset(); #define Const /*nothing*/ #ifdef ungetc static int un_getc(x,f__cf) int x; FILE *f__cf; { return ungetc(x,f__cf); } #else #define un_getc ungetc extern int ungetc(); #endif #else #define Const const #undef abs #undef min #undef max #include "stdlib.h" #include "string.h" #ifdef __cplusplus extern "C" { #endif #ifdef ungetc static int un_getc(int x, FILE *f__cf) { return ungetc(x,f__cf); } #else #define un_getc ungetc extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ #endif #endif static Vardesc * #ifdef KR_headers hash(ht, s) hashtab *ht; register char *s; #else hash(hashtab *ht, register char *s) #endif { register int c, x; register hashentry *h; char *s0 = s; for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) x += c; for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) if (!strcmp(s0, h->name)) return h->vd; return 0; } hashtab * #ifdef KR_headers mk_hashtab(nl) Namelist *nl; #else mk_hashtab(Namelist *nl) #endif { int nht, nv; hashtab *ht; Vardesc *v, **vd, **vde; hashentry *he; hashtab **x, **x0, *y; for(x = &nl_cache; y = *x; x0 = x, x = &y->next) if (nl == y->nl) return y; if (n_nlcache >= MAX_NL_CACHE) { /* discard least recently used namelist hash table */ y = *x0; free((char *)y->next); y->next = 0; } else n_nlcache++; nv = nl->nvars; if (nv >= 0x4000) nht = 0x7fff; else { for(nht = 1; nht < nv; nht <<= 1); nht += nht - 1; } ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) + nv*sizeof(hashentry)); if (!ht) return 0; he = (hashentry *)&ht->tab[nht]; ht->nl = nl; ht->htsize = nht; ht->next = nl_cache; nl_cache = ht; memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); vd = nl->vars; vde = vd + nv; while(vd < vde) { v = *vd++; if (!hash(ht, v->name)) { he->next = *zot; *zot = he; he->name = v->name; he->vd = v; he++; } } return ht; } static char Alpha[256], Alphanum[256]; static VOID nl_init(Void) { Const char *s; int c; if(!f__init) f_init(); for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) Alpha[c] = Alphanum[c] = Alpha[c + 'a' - 'A'] = Alphanum[c + 'a' - 'A'] = c; for(s = "0123456789_"; c = *s++; ) Alphanum[c] = c; } #define GETC(x) (x=(*l_getc)()) #define Ungetc(x,y) (*l_ungetc)(x,y) static int #ifdef KR_headers getname(s, slen) register char *s; int slen; #else getname(register char *s, int slen) #endif { register char *se = s + slen - 1; register int ch; GETC(ch); if (!(*s++ = Alpha[ch & 0xff])) { if (ch != EOF) ch = 115; errfl(f__elist->cierr, ch, "namelist read"); } while(*s = Alphanum[GETC(ch) & 0xff]) if (s < se) s++; if (ch == EOF) err(f__elist->cierr, EOF, "namelist read"); if (ch > ' ') Ungetc(ch,f__cf); return *s = 0; } static int #ifdef KR_headers getnum(chp, val) int *chp; ftnlen *val; #else getnum(int *chp, ftnlen *val) #endif { register int ch, sign; register ftnlen x; while(GETC(ch) <= ' ' && ch >= 0); if (ch == '-') { sign = 1; GETC(ch); } else { sign = 0; if (ch == '+') GETC(ch); } x = ch - '0'; if (x < 0 || x > 9) return 115; while(GETC(ch) >= '0' && ch <= '9') x = 10*x + ch - '0'; while(ch <= ' ' && ch >= 0) GETC(ch); if (ch == EOF) return EOF; *val = sign ? -x : x; *chp = ch; return 0; } static int #ifdef KR_headers getdimen(chp, d, delta, extent, x1) int *chp; dimen *d; ftnlen delta, extent, *x1; #else getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) #endif { register int k; ftnlen x2, x3; if (k = getnum(chp, x1)) return k; x3 = 1; if (*chp == ':') { if (k = getnum(chp, &x2)) return k; x2 -= *x1; if (*chp == ':') { if (k = getnum(chp, &x3)) return k; if (!x3) return 123; x2 /= x3; colonseen = 1; } if (x2 < 0 || x2 >= extent) return 123; d->extent = x2 + 1; } else d->extent = 1; d->curval = 0; d->delta = delta; d->stride = x3; return 0; } #ifndef No_Namelist_Questions static Void #ifdef KR_headers print_ne(a) cilist *a; #else print_ne(cilist *a) #endif { flag intext = f__external; int rpsave = f__recpos; FILE *cfsave = f__cf; unit *usave = f__curunit; cilist t; t = *a; t.ciunit = 6; s_wsne(&t); fflush(f__cf); f__external = intext; f__reading = 1; f__recpos = rpsave; f__cf = cfsave; f__curunit = usave; f__elist = a; } #endif static char where0[] = "namelist read start "; int #ifdef KR_headers x_rsne(a) cilist *a; #else x_rsne(cilist *a) #endif { int ch, got1, k, n, nd, quote, readall; Namelist *nl; static char where[] = "namelist read"; char buf[64]; hashtab *ht; Vardesc *v; dimen *dn, *dn0, *dn1; ftnlen *dims, *dims1; ftnlen b, b0, b1, ex, no, nomax, size, span; ftnint no1, no2, type; char *vaddr; long iva, ivae; dimen dimens[MAXDIM], substr; if (!Alpha['a']) nl_init(); f__reading=1; f__formatted=1; got1 = 0; top: for(;;) switch(GETC(ch)) { case EOF: eof: err(a->ciend,(EOF),where0); case '&': case '$': goto have_amp; #ifndef No_Namelist_Questions case '?': print_ne(a); continue; #endif default: if (ch <= ' ' && ch >= 0) continue; #ifndef No_Namelist_Comments while(GETC(ch) != '\n') if (ch == EOF) goto eof; #else errfl(a->cierr, 115, where0); #endif } have_amp: if (ch = getname(buf,sizeof(buf))) return ch; nl = (Namelist *)a->cifmt; if (strcmp(buf, nl->name)) #ifdef No_Bad_Namelist_Skip errfl(a->cierr, 118, where0); #else { fprintf(stderr, "Skipping namelist \"%s\": seeking namelist \"%s\".\n", buf, nl->name); fflush(stderr); for(;;) switch(GETC(ch)) { case EOF: err(a->ciend, EOF, where0); case '/': case '&': case '$': if (f__external) e_rsle(); else z_rnew(); goto top; case '"': case '\'': quote = ch; more_quoted: while(GETC(ch) != quote) if (ch == EOF) err(a->ciend, EOF, where0); if (GETC(ch) == quote) goto more_quoted; Ungetc(ch,f__cf); default: continue; } } #endif ht = mk_hashtab(nl); if (!ht) errfl(f__elist->cierr, 113, where0); for(;;) { for(;;) switch(GETC(ch)) { case EOF: if (got1) return 0; err(a->ciend, EOF, where0); case '/': case '$': case '&': return 0; default: if (ch <= ' ' && ch >= 0 || ch == ',') continue; Ungetc(ch,f__cf); if (ch = getname(buf,sizeof(buf))) return ch; goto havename; } havename: v = hash(ht,buf); if (!v) errfl(a->cierr, 119, where); while(GETC(ch) <= ' ' && ch >= 0); vaddr = v->addr; type = v->type; if (type < 0) { size = -type; type = TYCHAR; } else size = f__typesize[type]; ivae = size; iva = readall = 0; if (ch == '(' /*)*/ ) { dn = dimens; if (!(dims = v->dims)) { if (type != TYCHAR) errfl(a->cierr, 122, where); if (k = getdimen(&ch, dn, (ftnlen)size, (ftnlen)size, &b)) errfl(a->cierr, k, where); if (ch != ')') errfl(a->cierr, 115, where); b1 = dn->extent; if (--b < 0 || b + b1 > size) return 124; iva += b; size = b1; while(GETC(ch) <= ' ' && ch >= 0); goto scalar; } nd = (int)dims[0]; nomax = span = dims[1]; ivae = iva + size*nomax; colonseen = 0; if (k = getdimen(&ch, dn, size, nomax, &b)) errfl(a->cierr, k, where); no = dn->extent; b0 = dims[2]; dims1 = dims += 3; ex = 1; for(n = 1; n++ < nd; dims++) { if (ch != ',') errfl(a->cierr, 115, where); dn1 = dn + 1; span /= *dims; if (k = getdimen(&ch, dn1, dn->delta**dims, span, &b1)) errfl(a->cierr, k, where); ex *= *dims; b += b1*ex; no *= dn1->extent; dn = dn1; } if (ch != ')') errfl(a->cierr, 115, where); readall = 1 - colonseen; b -= b0; if (b < 0 || b >= nomax) errfl(a->cierr, 125, where); iva += size * b; dims = dims1; while(GETC(ch) <= ' ' && ch >= 0); no1 = 1; dn0 = dimens; if (type == TYCHAR && ch == '(' /*)*/) { if (k = getdimen(&ch, &substr, size, size, &b)) errfl(a->cierr, k, where); if (ch != ')') errfl(a->cierr, 115, where); b1 = substr.extent; if (--b < 0 || b + b1 > size) return 124; iva += b; b0 = size; size = b1; while(GETC(ch) <= ' ' && ch >= 0); if (b1 < b0) goto delta_adj; } if (readall) goto delta_adj; for(; dn0 < dn; dn0++) { if (dn0->extent != *dims++ || dn0->stride != 1) break; no1 *= dn0->extent; } if (dn0 == dimens && dimens[0].stride == 1) { no1 = dimens[0].extent; dn0++; } delta_adj: ex = 0; for(dn1 = dn0; dn1 <= dn; dn1++) ex += (dn1->extent-1) * (dn1->delta *= dn1->stride); for(dn1 = dn; dn1 > dn0; dn1--) { ex -= (dn1->extent - 1) * dn1->delta; dn1->delta -= ex; } } else if (dims = v->dims) { no = no1 = dims[1]; ivae = iva + no*size; } else scalar: no = no1 = 1; if (ch != '=') errfl(a->cierr, 115, where); got1 = nml_read = 1; f__lcount = 0; readloop: for(;;) { if (iva >= ivae || iva < 0) { f__lquit = 1; goto mustend; } else if (iva + no1*size > ivae) no1 = (ivae - iva)/size; f__lquit = 0; if (k = l_read(&no1, vaddr + iva, size, type)) return k; if (f__lquit == 1) return 0; if (readall) { iva += dn0->delta; if (f__lcount > 0) { no2 = (ivae - iva)/size; if (no2 > f__lcount) no2 = f__lcount; if (k = l_read(&no2, vaddr + iva, size, type)) return k; iva += no2 * dn0->delta; } } mustend: GETC(ch); if (readall) if (iva >= ivae) readall = 0; else for(;;) { switch(ch) { case ' ': case '\t': case '\n': GETC(ch); continue; } break; } if (ch == '/' || ch == '$' || ch == '&') { f__lquit = 1; return 0; } else if (f__lquit) { while(ch <= ' ' && ch >= 0) GETC(ch); Ungetc(ch,f__cf); if (!Alpha[ch & 0xff] && ch >= 0) errfl(a->cierr, 125, where); break; } Ungetc(ch,f__cf); if (readall && !Alpha[ch & 0xff]) goto readloop; if ((no -= no1) <= 0) break; for(dn1 = dn0; dn1 <= dn; dn1++) { if (++dn1->curval < dn1->extent) { iva += dn1->delta; goto readloop; } dn1->curval = 0; } break; } } } integer #ifdef KR_headers s_rsne(a) cilist *a; #else s_rsne(cilist *a) #endif { extern int l_eof; int n; f__external=1; l_eof = 0; if(n = c_le(a)) return n; if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr,errno,where0); l_getc = t_getc; l_ungetc = un_getc; f__doend = xrd_SL; n = x_rsne(a); nml_read = 0; if (n) return n; return e_rsle(); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/s_cat.c0000644000175000017500000000266211236375625014165 0ustar afrb2afrb2/* 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 exit_(); #else #undef min #undef max #include "stdlib.h" extern #ifdef __cplusplus "C" #endif char *F77_aloc(ftnlen, const char*); #endif #include "string.h" #endif /* NO_OVERWRITE */ #ifdef __cplusplus extern "C" { #endif VOID #ifdef KR_headers s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll; #else s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *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 } #ifdef __cplusplus } #endif libf2c2-20090411.orig/s_cmp.c0000644000175000017500000000132211236375625014165 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif /* 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); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/s_copy.c0000644000175000017500000000200011236375625014352 0ustar afrb2afrb2/* 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" #ifdef __cplusplus extern "C" { #endif /* 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++ = ' '; } } #ifdef __cplusplus } #endif libf2c2-20090411.orig/s_paus.c0000644000175000017500000000312111236375625014355 0ustar afrb2afrb2#include "stdio.h" #include "f2c.h" #define PAUSESIG 15 #include "signal1.h" #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" #ifdef __cplusplus extern "C" { #endif #ifdef __cplusplus extern "C" { #endif extern int getpid(void), isatty(int), pause(void); #endif extern VOID f_exit(Void); #ifndef MSDOS static VOID waitpause(Sigarg) { Use_Sigarg; return; } #endif 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 { #ifdef MSDOS 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 } #ifdef __cplusplus } #endif libf2c2-20090411.orig/s_rnge.c0000644000175000017500000000136711236375625014352 0ustar afrb2afrb2#include "stdio.h" #include "f2c.h" #ifdef __cplusplus extern "C" { #endif /* 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(const 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 ", (long)line); while((i = *procn) && i != '_' && i != ' ') putc(*procn++, stderr); fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", (long)offset+1); while((i = *varn) && i != ' ') putc(*varn++, stderr); sig_die(".", 1); return 0; /* not reached */ } #ifdef __cplusplus } #endif libf2c2-20090411.orig/s_stop.c0000644000175000017500000000137211236375625014400 0ustar afrb2afrb2#include "stdio.h" #include "f2c.h" #ifdef KR_headers extern void f_exit(); int s_stop(s, n) char *s; ftnlen n; #else #undef abs #undef min #undef max #include "stdlib.h" #ifdef __cplusplus extern "C" { #endif #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; iciunit]; if(a->ciunit >= MXUNIT || a->ciunit<0) err(a->cierr,101,"startio"); if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") if(!p->ufmt) err(a->cierr,102,"sfe") return(0); } integer e_wsfe(Void) { int n = en_fio(); f__fmtbuf = NULL; #ifdef ALWAYS_FLUSH if (!n && fflush(f__cf)) err(f__elist->cierr, errno, "write end"); #endif return n; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/sig_die.c0000644000175000017500000000126111236375625014471 0ustar afrb2afrb2#include "stdio.h" #include "signal.h" #ifndef SIGIOT #ifdef SIGABRT #define SIGIOT SIGABRT #endif #endif #ifdef KR_headers void sig_die(s, kill) char *s; int kill; #else #include "stdlib.h" #ifdef __cplusplus extern "C" { #endif #ifdef __cplusplus extern "C" { #endif extern void f_exit(void); void sig_die(const 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 #ifdef __cplusplus } #endif libf2c2-20090411.orig/signal1.h00000644000175000017500000000151211236375625014510 0ustar afrb2afrb2/* 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. */ /* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ #include #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) #ifdef __cplusplus #define Sigarg ... #define Use_Sigarg #else #define Sigarg Int n #define Use_Sigarg n = n /* shut up compiler warning */ #endif libf2c2-20090411.orig/signal_.c0000644000175000017500000000045311236375625014504 0ustar afrb2afrb2#include "f2c.h" #include "signal1.h" #ifdef __cplusplus extern "C" { #endif ftnint #ifdef KR_headers signal_(sigp, proc) integer *sigp; sig_pf proc; #else signal_(integer *sigp, sig_pf proc) #endif { int sig; sig = (int)*sigp; return (ftnint)signal(sig, proc); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/signbit.c0000644000175000017500000000051211236375625014523 0ustar afrb2afrb2#include "arith.h" #ifndef Long #define Long long #endif int #ifdef KR_headers signbit_f2c(x) double *x; #else signbit_f2c(double *x) #endif { #ifdef IEEE_MC68k if (*(Long*)x & 0x80000000) return 1; #else #ifdef IEEE_8087 if (((Long*)x)[1] & 0x80000000) return 1; #endif /*IEEE_8087*/ #endif /*IEEE_MC68k*/ return 0; } libf2c2-20090411.orig/sue.c0000644000175000017500000000351111236375625013662 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif extern uiolen f__reclen; OFF_T f__recloc; int #ifdef KR_headers c_sue(a) cilist *a; #else c_sue(cilist *a) #endif { f__external=f__sequential=1; f__formatted=0; f__curunit = &f__units[a->ciunit]; if(a->ciunit >= MXUNIT || a->ciunit < 0) err(a->cierr,101,"startio"); f__elist=a; if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) err(a->cierr,114,"sue"); f__cf=f__curunit->ufd; if(f__curunit->ufmt) err(a->cierr,103,"sue") if(!f__curunit->useek) err(a->cierr,103,"sue") return(0); } #ifdef KR_headers integer s_rsue(a) cilist *a; #else integer s_rsue(cilist *a) #endif { int n; if(!f__init) f_init(); f__reading=1; if(n=c_sue(a)) return(n); f__recpos=0; if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr, errno, "read start"); if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) != 1) { if(feof(f__cf)) { f__curunit->uend = 1; err(a->ciend, EOF, "start"); } clearerr(f__cf); err(a->cierr, errno, "start"); } return(0); } #ifdef KR_headers integer s_wsue(a) cilist *a; #else integer s_wsue(cilist *a) #endif { int n; if(!f__init) f_init(); if(n=c_sue(a)) return(n); f__reading=0; f__reclen=0; if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) err(a->cierr, errno, "write start"); f__recloc=FTELL(f__cf); FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR); return(0); } integer e_wsue(Void) { OFF_T loc; fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); #ifdef ALWAYS_FLUSH if (fflush(f__cf)) err(f__elist->cierr, errno, "write end"); #endif loc=FTELL(f__cf); FSEEK(f__cf,f__recloc,SEEK_SET); fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); FSEEK(f__cf,loc,SEEK_SET); return(0); } integer e_rsue(Void) { FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); return(0); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/sysdep1.h00000644000175000017500000000226211236375625014545 0ustar afrb2afrb2#ifndef SYSDEP_H_INCLUDED #define SYSDEP_H_INCLUDED #undef USE_LARGEFILE #ifndef NO_LONG_LONG #ifdef __sun__ #define USE_LARGEFILE #define OFF_T off64_t #endif #ifdef __linux__ #define USE_LARGEFILE #define OFF_T __off64_t #endif #ifdef _AIX43 #define _LARGE_FILES #define _LARGE_FILE_API #define USE_LARGEFILE #endif /*_AIX43*/ #ifdef __hpux #define _FILE64 #define _LARGEFILE64_SOURCE #define USE_LARGEFILE #endif /*__hpux*/ #ifdef __sgi #define USE_LARGEFILE #endif /*__sgi*/ #ifdef __FreeBSD__ #define OFF_T off_t #define FSEEK fseeko #define FTELL ftello #endif #ifdef USE_LARGEFILE #ifndef OFF_T #define OFF_T off64_t #endif #define _LARGEFILE_SOURCE #define _LARGEFILE64_SOURCE #include #include #define FOPEN fopen64 #define FREOPEN freopen64 #define FSEEK fseeko64 #define FSTAT fstat64 #define FTELL ftello64 #define FTRUNCATE ftruncate64 #define STAT stat64 #define STAT_ST stat64 #endif /*USE_LARGEFILE*/ #endif /*NO_LONG_LONG*/ #ifndef NON_UNIX_STDIO #ifndef USE_LARGEFILE #define _INCLUDE_POSIX_SOURCE /* for HP-UX */ #define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ #include "sys/types.h" #include "sys/stat.h" #endif #endif #endif /*SYSDEP_H_INCLUDED*/ libf2c2-20090411.orig/system_.c0000644000175000017500000000121411236375625014547 0ustar afrb2afrb2/* f77 interface to system routine */ #include "f2c.h" #ifdef KR_headers extern char *F77_aloc(); integer system_(s, n) register char *s; ftnlen n; #else #undef abs #undef min #undef max #include "stdlib.h" #ifdef __cplusplus extern "C" { #endif extern char *F77_aloc(ftnlen, const char*); integer system_(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; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/typesize.c0000644000175000017500000000060211236375625014740 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), sizeof(real), sizeof(doublereal), sizeof(complex), sizeof(doublecomplex), sizeof(logical), sizeof(char), 0, sizeof(integer1), sizeof(logical1), sizeof(shortlogical), #ifdef Allow_TYQUAD sizeof(longint), #endif 0}; #ifdef __cplusplus } #endif libf2c2-20090411.orig/uio.c0000644000175000017500000000312311236375625013661 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif uiolen f__reclen; int #ifdef KR_headers do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; #else do_us(ftnint *number, char *ptr, ftnlen len) #endif { if(f__reading) { f__recpos += (int)(*number * len); if(f__recpos>f__reclen) err(f__elist->cierr, 110, "do_us"); if (fread(ptr,(int)len,(int)(*number),f__cf) != *number) err(f__elist->ciend, EOF, "do_us"); return(0); } else { f__reclen += *number * len; (void) fwrite(ptr,(int)len,(int)(*number),f__cf); return(0); } } #ifdef KR_headers integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; #else integer do_ud(ftnint *number, char *ptr, ftnlen len) #endif { f__recpos += (int)(*number * len); if(f__recpos > f__curunit->url && f__curunit->url!=1) err(f__elist->cierr,110,"do_ud"); if(f__reading) { #ifdef Pad_UDread #ifdef KR_headers int i; #else size_t i; #endif if (!(i = fread(ptr,(int)len,(int)(*number),f__cf)) && !(f__recpos - *number*len)) err(f__elist->cierr,EOF,"do_ud") if (i < *number) memset(ptr + i*len, 0, (*number - i)*len); return 0; #else if(fread(ptr,(int)len,(int)(*number),f__cf) != *number) err(f__elist->cierr,EOF,"do_ud") else return(0); #endif } (void) fwrite(ptr,(int)len,(int)(*number),f__cf); return(0); } #ifdef KR_headers integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; #else integer do_uio(ftnint *number, char *ptr, ftnlen len) #endif { if(f__sequential) return(do_us(number,ptr,len)); else return(do_ud(number,ptr,len)); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/uninit.c0000644000175000017500000001664011236375625014403 0ustar afrb2afrb2#include #include #include "arith.h" #define TYSHORT 2 #define TYLONG 3 #define TYREAL 4 #define TYDREAL 5 #define TYCOMPLEX 6 #define TYDCOMPLEX 7 #define TYINT1 11 #define TYQUAD 14 #ifndef Long #define Long long #endif #ifdef __mips #define RNAN 0xffc00000 #define DNAN0 0xfff80000 #define DNAN1 0 #endif #ifdef _PA_RISC1_1 #define RNAN 0xffc00000 #define DNAN0 0xfff80000 #define DNAN1 0 #endif #ifndef RNAN #define RNAN 0xff800001 #ifdef IEEE_MC68k #define DNAN0 0xfff00000 #define DNAN1 1 #else #define DNAN0 1 #define DNAN1 0xfff00000 #endif #endif /*RNAN*/ #ifdef KR_headers #define Void /*void*/ #define FA7UL (unsigned Long) 0xfa7a7a7aL #else #define Void void #define FA7UL 0xfa7a7a7aUL #endif #ifdef __cplusplus extern "C" { #endif static void ieee0(Void); static unsigned Long rnan = RNAN, dnan0 = DNAN0, dnan1 = DNAN1; double _0 = 0.; void #ifdef KR_headers _uninit_f2c(x, type, len) void *x; int type; long len; #else _uninit_f2c(void *x, int type, long len) #endif { static int first = 1; unsigned Long *lx, *lxe; if (first) { first = 0; ieee0(); } if (len == 1) switch(type) { case TYINT1: *(char*)x = 'Z'; return; case TYSHORT: *(short*)x = 0xfa7a; break; case TYLONG: *(unsigned Long*)x = FA7UL; return; case TYQUAD: case TYCOMPLEX: case TYDCOMPLEX: break; case TYREAL: *(unsigned Long*)x = rnan; return; case TYDREAL: lx = (unsigned Long*)x; lx[0] = dnan0; lx[1] = dnan1; return; default: printf("Surprise type %d in _uninit_f2c\n", type); } switch(type) { case TYINT1: memset(x, 'Z', len); break; case TYSHORT: *(short*)x = 0xfa7a; break; case TYQUAD: len *= 2; /* no break */ case TYLONG: lx = (unsigned Long*)x; lxe = lx + len; while(lx < lxe) *lx++ = FA7UL; break; case TYCOMPLEX: len *= 2; /* no break */ case TYREAL: lx = (unsigned Long*)x; lxe = lx + len; while(lx < lxe) *lx++ = rnan; break; case TYDCOMPLEX: len *= 2; /* no break */ case TYDREAL: lx = (unsigned Long*)x; for(lxe = lx + 2*len; lx < lxe; lx += 2) { lx[0] = dnan0; lx[1] = dnan1; } } } #ifdef __cplusplus } #endif #ifndef MSpc #ifdef MSDOS #define MSpc #else #ifdef _WIN32 #define MSpc #endif #endif #endif #ifdef MSpc #define IEEE0_done #include "float.h" #include "signal.h" static void ieee0(Void) { #ifndef __alpha #ifndef EM_DENORMAL #define EM_DENORMAL _EM_DENORMAL #endif #ifndef EM_UNDERFLOW #define EM_UNDERFLOW _EM_UNDERFLOW #endif #ifndef EM_INEXACT #define EM_INEXACT _EM_INEXACT #endif #ifndef MCW_EM #define MCW_EM _MCW_EM #endif _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM); #endif /* With MS VC++, compiling and linking with -Zi will permit */ /* clicking to invoke the MS C++ debugger, which will show */ /* the point of error -- provided SIGFPE is SIG_DFL. */ signal(SIGFPE, SIG_DFL); } #endif /* MSpc */ #ifdef __mips /* must link with -lfpe */ #define IEEE0_done /* code from Eric Grosse */ #include #include #include "/usr/include/sigfpe.h" /* full pathname for lcc -N */ #include "/usr/include/sys/fpu.h" static void #ifdef KR_headers ieeeuserhand(exception, val) unsigned exception[5]; int val[2]; #else ieeeuserhand(unsigned exception[5], int val[2]) #endif { fflush(stdout); fprintf(stderr,"ieee0() aborting because of "); if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n"); else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n"); else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n"); else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n"); else fprintf(stderr,"\tunknown reason\n"); fflush(stderr); abort(); } static void #ifdef KR_headers ieeeuserhand2(j) unsigned int **j; #else ieeeuserhand2(unsigned int **j) #endif { fprintf(stderr,"ieee0() aborting because of confusion\n"); abort(); } static void ieee0(Void) { int i; for(i=1; i<=4; i++){ sigfpe_[i].count = 1000; sigfpe_[i].trace = 1; sigfpe_[i].repls = _USER_DETERMINED; } sigfpe_[1].repls = _ZERO; /* underflow */ handle_sigfpes( _ON, _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); } #endif /* mips */ #ifdef __linux__ #define IEEE0_done #include "fpu_control.h" #ifdef __alpha__ #ifndef USE_setfpucw #define __setfpucw(x) __fpu_control = (x) #endif #endif #ifndef _FPU_SETCW #undef Can_use__setfpucw #define Can_use__setfpucw #endif static void ieee0(Void) { #if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) /* Reported 20010705 by Alan Bain */ /* Note that IEEE 754 IOP (illegal operation) */ /* = Signaling NAN (SNAN) + operation error (OPERR). */ #ifdef Can_use__setfpucw __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); #else __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; _FPU_SETCW(__fpu_control); #endif #elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ /* Reported 20011109 by Alan Bain */ #ifdef Can_use__setfpucw /* The following is NOT a mistake -- the author of the fpu_control.h for the PPC has erroneously defined IEEE mode to turn on exceptions other than Inexact! Start from default then and turn on only the ones which we want*/ __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); #else /* PPC && !Can_use__setfpucw */ __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; _FPU_SETCW(__fpu_control); #endif /*Can_use__setfpucw*/ #else /* !(mc68000||powerpc) */ #ifdef _FPU_IEEE #ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ #define _FPU_EXTENDED 0 #endif #ifndef _FPU_DOUBLE #define _FPU_DOUBLE 0 #endif #ifdef Can_use__setfpucw /* pre-1997 (?) Linux */ __setfpucw(_FPU_IEEE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); #else #ifdef UNINIT_F2C_PRECISION_53 /* 20051004 */ /* unmask invalid, etc., and change rounding precision to double */ __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; _FPU_SETCW(__fpu_control); #else /* unmask invalid, etc., and keep current rounding precision */ fpu_control_t cw; _FPU_GETCW(cw); cw &= ~(_FPU_MASK_IM | _FPU_MASK_ZM | _FPU_MASK_OM); _FPU_SETCW(cw); #endif #endif #else /* !_FPU_IEEE */ fprintf(stderr, "\n%s\n%s\n%s\n%s\n", "WARNING: _uninit_f2c in libf2c does not know how", "to enable trapping on this system, so f2c's -trapuv", "option will not detect uninitialized variables unless", "you can enable trapping manually."); fflush(stderr); #endif /* _FPU_IEEE */ #endif /* __mc68k__ */ } #endif /* __linux__ */ #ifdef __alpha #ifndef IEEE0_done #define IEEE0_done #include static void ieee0(Void) { ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); } #endif /*IEEE0_done*/ #endif /*__alpha*/ #ifdef __hpux #define IEEE0_done #define _INCLUDE_HPUX_SOURCE #include #ifndef FP_X_INV #include #define fpsetmask fesettrapenable #define FP_X_INV FE_INVALID #endif static void ieee0(Void) { fpsetmask(FP_X_INV); } #endif /*__hpux*/ #ifdef _AIX #define IEEE0_done #include static void ieee0(Void) { fp_enable(TRP_INVALID); fp_trap(FP_TRAP_SYNC); } #endif /*_AIX*/ #ifdef __sun #define IEEE0_done #include static void ieee0(Void) { fpsetmask(FP_X_INV); } #endif /*__sparc*/ #ifndef IEEE0_done static void ieee0(Void) {} #endif libf2c2-20090411.orig/util.c0000644000175000017500000000171411236375625014046 0ustar afrb2afrb2#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ #include "f2c.h" #include "fio.h" #ifdef __cplusplus extern "C" { #endif VOID #ifdef KR_headers #define Const /*nothing*/ g_char(a,alen,b) char *a,*b; ftnlen alen; #else #define Const const g_char(const char *a, ftnlen alen, char *b) #endif { Const char *x = a + alen; char *y = b + alen; for(;; y--) { if (x <= a) { *b = 0; return; } if (*--x != ' ') break; } *y-- = 0; do *y-- = *x; while(x-- > a); } VOID #ifdef KR_headers b_char(a,b,blen) char *a,*b; ftnlen blen; #else b_char(const char *a, char *b, ftnlen blen) #endif { int i; for(i=0;i= d + 2 || f__scale <= -d) goto nogood; } if(f__scale <= 0) --d; if (len == sizeof(real)) dd = p->pf; else dd = p->pd; if (dd < 0.) { signspace = sign = 1; dd = -dd; } else { sign = 0; signspace = (int)f__cplus; #ifndef VAX if (!dd) { #ifdef SIGNED_ZEROS if (signbit_f2c(&dd)) signspace = sign = 1; #endif dd = 0.; /* avoid -0 */ } #endif } delta = w - (2 /* for the . and the d adjustment above */ + 2 /* for the E+ */ + signspace + d + e); #ifdef WANT_LEAD_0 if (f__scale <= 0 && delta > 0) { delta--; insert0 = 1; } else #endif if (delta < 0) { nogood: while(--w >= 0) PUT('*'); return(0); } if (f__scale < 0) d += f__scale; if (d > FMAX) { d1 = d - FMAX; d = FMAX; } else d1 = 0; sprintf(buf,"%#.*E", d, dd); #ifndef VAX /* check for NaN, Infinity */ if (!isdigit(buf[0])) { switch(buf[0]) { case 'n': case 'N': signspace = 0; /* no sign for NaNs */ } delta = w - strlen(buf) - signspace; if (delta < 0) goto nogood; while(--delta >= 0) PUT(' '); if (signspace) PUT(sign ? '-' : '+'); for(s = buf; *s; s++) PUT(*s); return 0; } #endif se = buf + d + 3; #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ if (f__scale != 1 && dd) sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); #else if (dd) sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); else strcpy(se, "+00"); #endif s = ++se; if (e < 2) { if (*s != '0') goto nogood; } #ifndef VAX /* accommodate 3 significant digits in exponent */ if (s[2]) { #ifdef Pedantic if (!e0 && !s[3]) for(s -= 2, e1 = 2; s[0] = s[1]; s++); /* Pedantic gives the behavior that Fortran 77 specifies, */ /* i.e., requires that E be specified for exponent fields */ /* of more than 3 digits. With Pedantic undefined, we get */ /* the behavior that Cray displays -- you get a bigger */ /* exponent field if it fits. */ #else if (!e0) { for(s -= 2, e1 = 2; s[0] = s[1]; s++) #ifdef CRAY delta--; if ((delta += 4) < 0) goto nogood #endif ; } #endif else if (e0 >= 0) goto shift; else e1 = e; } else shift: #endif for(s += 2, e1 = 2; *s; ++e1, ++s) if (e1 >= e) goto nogood; while(--delta >= 0) PUT(' '); if (signspace) PUT(sign ? '-' : '+'); s = buf; i = f__scale; if (f__scale <= 0) { #ifdef WANT_LEAD_0 if (insert0) PUT('0'); #endif PUT('.'); for(; i < 0; ++i) PUT('0'); PUT(*s); s += 2; } else if (f__scale > 1) { PUT(*s); s += 2; while(--i > 0) PUT(*s++); PUT('.'); } if (d1) { se -= 2; while(s < se) PUT(*s++); se += 2; do PUT('0'); while(--d1 > 0); } while(s < se) PUT(*s++); if (e < 2) PUT(s[1]); else { while(++e1 <= e) PUT('0'); while(*s) PUT(*s++); } return 0; } int #ifdef KR_headers wrt_F(p,w,d,len) ufloat *p; ftnlen len; #else wrt_F(ufloat *p, int w, int d, ftnlen len) #endif { int d1, sign, n; double x; char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; x= (len==sizeof(real)?p->pf:p->pd); if (d < MAXFRACDIGS) d1 = 0; else { d1 = d - MAXFRACDIGS; d = MAXFRACDIGS; } if (x < 0.) { x = -x; sign = 1; } else { sign = 0; #ifndef VAX if (!x) { #ifdef SIGNED_ZEROS if (signbit_f2c(&x)) sign = 2; #endif x = 0.; } #endif } if (n = f__scale) if (n > 0) do x *= 10.; while(--n > 0); else do x *= 0.1; while(++n < 0); #ifdef USE_STRLEN sprintf(b = buf, "%#.*f", d, x); n = strlen(b) + d1; #else n = sprintf(b = buf, "%#.*f", d, x) + d1; #endif #ifndef WANT_LEAD_0 if (buf[0] == '0' && d) { ++b; --n; } #endif if (sign == 1) { /* check for all zeros */ for(s = b;;) { while(*s == '0') s++; switch(*s) { case '.': s++; continue; case 0: sign = 0; } break; } } if (sign || f__cplus) ++n; if (n > w) { #ifdef WANT_LEAD_0 if (buf[0] == '0' && --n == w) ++b; else #endif { while(--w >= 0) PUT('*'); return 0; } } for(w -= n; --w >= 0; ) PUT(' '); if (sign) PUT('-'); else if (f__cplus) PUT('+'); while(n = *b++) PUT(n); while(--d1 >= 0) PUT('0'); return 0; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/wrtfmt.c0000644000175000017500000001652211236375625014417 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "fmt.h" #ifdef __cplusplus extern "C" { #endif extern icilist *f__svic; extern char *f__icptr; static int mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ /* instead we know too much about stdio */ { int cursor = f__cursor; f__cursor = 0; if(f__external == 0) { if(cursor < 0) { if(f__hiwater < f__recpos) f__hiwater = f__recpos; f__recpos += cursor; f__icptr += cursor; if(f__recpos < 0) err(f__elist->cierr, 110, "left off"); } else if(cursor > 0) { if(f__recpos + cursor >= f__svic->icirlen) err(f__elist->cierr, 110, "recend"); if(f__hiwater <= f__recpos) for(; cursor > 0; cursor--) (*f__putn)(' '); else if(f__hiwater <= f__recpos + cursor) { cursor -= f__hiwater - f__recpos; f__icptr += f__hiwater - f__recpos; f__recpos = f__hiwater; for(; cursor > 0; cursor--) (*f__putn)(' '); } else { f__icptr += cursor; f__recpos += cursor; } } return(0); } if (cursor > 0) { if(f__hiwater <= f__recpos) for(;cursor>0;cursor--) (*f__putn)(' '); else if(f__hiwater <= f__recpos + cursor) { cursor -= f__hiwater - f__recpos; f__recpos = f__hiwater; for(; cursor > 0; cursor--) (*f__putn)(' '); } else { f__recpos += cursor; } } else if (cursor < 0) { if(cursor + f__recpos < 0) err(f__elist->cierr,110,"left off"); if(f__hiwater < f__recpos) f__hiwater = f__recpos; f__recpos += cursor; } return(0); } static int #ifdef KR_headers wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; #else wrt_Z(Uint *n, int w, int minlen, ftnlen len) #endif { register char *s, *se; register int i, w1; static int one = 1; static char hex[] = "0123456789ABCDEF"; s = (char *)n; --len; if (*(char *)&one) { /* little endian */ se = s; s += len; i = -1; } else { se = s + len; i = 1; } for(;; s += i) if (s == se || *s) break; w1 = (i*(se-s) << 1) + 1; if (*s & 0xf0) w1++; if (w1 > w) for(i = 0; i < w; i++) (*f__putn)('*'); else { if ((minlen -= w1) > 0) w1 += minlen; while(--w >= w1) (*f__putn)(' '); while(--minlen >= 0) (*f__putn)('0'); if (!(*s & 0xf0)) { (*f__putn)(hex[*s & 0xf]); if (s == se) return 0; s += i; } for(;; s += i) { (*f__putn)(hex[*s >> 4 & 0xf]); (*f__putn)(hex[*s & 0xf]); if (s == se) break; } } return 0; } static int #ifdef KR_headers wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; #else wrt_I(Uint *n, int w, ftnlen len, register int base) #endif { int ndigit,sign,spare,i; longint x; char *ans; if(len==sizeof(integer)) x=n->il; else if(len == sizeof(char)) x = n->ic; #ifdef Allow_TYQUAD else if (len == sizeof(longint)) x = n->ili; #endif else x=n->is; ans=f__icvt(x,&ndigit,&sign, base); spare=w-ndigit; if(sign || f__cplus) spare--; if(spare<0) for(i=0;iil; else if(len == sizeof(char)) x = n->ic; #ifdef Allow_TYQUAD else if (len == sizeof(longint)) x = n->ili; #endif else x=n->is; ans=f__icvt(x,&ndigit,&sign, base); if(sign || f__cplus) xsign=1; else xsign=0; if(ndigit+xsign>w || m+xsign>w) { for(i=0;i=m) spare=w-ndigit-xsign; else spare=w-m-xsign; for(i=0;iil; else if(sz == sizeof(char)) x = n->ic; else x=n->is; for(i=0;i 0) (*f__putn)(*p++); return(0); } static int #ifdef KR_headers wrt_AW(p,w,len) char * p; ftnlen len; #else wrt_AW(char * p, int w, ftnlen len) #endif { while(w>len) { w--; (*f__putn)(' '); } while(w-- > 0) (*f__putn)(*p++); return(0); } static int #ifdef KR_headers wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; #else wrt_G(ufloat *p, int w, int d, int e, ftnlen len) #endif { double up = 1,x; int i=0,oldscale,n,j; x = len==sizeof(real)?p->pf:p->pd; if(x < 0 ) x = -x; if(x<.1) { if (x != 0.) return(wrt_E(p,w,d,e,len)); i = 1; goto have_i; } for(;i<=d;i++,up*=10) { if(x>=up) continue; have_i: oldscale = f__scale; f__scale = 0; if(e==0) n=4; else n=e+2; i=wrt_F(p,w-n,d-i,len); for(j=0;jop) { default: fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); sig_die(f__fmtbuf, 1); case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); case IM: return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); /* O and OM don't work right for character, double, complex, */ /* or doublecomplex, and they differ from Fortran 90 in */ /* showing a minus sign for negative values. */ case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); case OM: return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); case L: return(wrt_L((Uint *)ptr,p->p1, len)); case A: return(wrt_A(ptr,len)); case AW: return(wrt_AW(ptr,p->p1,len)); case D: case E: case EE: return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); case G: case GE: return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); /* Z and ZM assume 8-bit bytes. */ case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); case ZM: return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); } } int #ifdef KR_headers w_ned(p) struct syl *p; #else w_ned(struct syl *p) #endif { switch(p->op) { default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); sig_die(f__fmtbuf, 1); case SLASH: return((*f__donewrec)()); case T: f__cursor = p->p1-f__recpos - 1; return(1); case TL: f__cursor -= p->p1; if(f__cursor < -f__recpos) /* TL1000, 1X */ f__cursor = -f__recpos; return(1); case TR: case X: f__cursor += p->p1; return(1); case APOS: return(wrt_AP(p->p2.s)); case H: return(wrt_H(p->p1,p->p2.s)); } } #ifdef __cplusplus } #endif libf2c2-20090411.orig/wsfe.c0000644000175000017500000000240011236375625014026 0ustar afrb2afrb2/*write sequential formatted external*/ #include "f2c.h" #include "fio.h" #include "fmt.h" #ifdef __cplusplus extern "C" { #endif int x_wSL(Void) { int n = f__putbuf('\n'); f__hiwater = f__recpos = f__cursor = 0; return(n == 0); } static int xw_end(Void) { int n; if(f__nonl) { f__putbuf(n = 0); fflush(f__cf); } else n = f__putbuf('\n'); f__hiwater = f__recpos = f__cursor = 0; return n; } static int xw_rev(Void) { int n = 0; if(f__workdone) { n = f__putbuf('\n'); f__workdone = 0; } f__hiwater = f__recpos = f__cursor = 0; return n; } #ifdef KR_headers integer s_wsfe(a) cilist *a; /*start*/ #else integer s_wsfe(cilist *a) /*start*/ #endif { int n; if(!f__init) f_init(); f__reading=0; f__sequential=1; f__formatted=1; f__external=1; if(n=c_sfe(a)) return(n); f__elist=a; f__hiwater = f__cursor=f__recpos=0; f__nonl = 0; f__scale=0; f__fmtbuf=a->cifmt; f__cf=f__curunit->ufd; if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); f__putn= x_putc; f__doed= w_ed; f__doned= w_ned; f__doend=xw_end; f__dorevert=xw_rev; f__donewrec=x_wSL; fmt_bg(); f__cplus=0; f__cblank=f__curunit->ublnk; if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) err(a->cierr,errno,"write start"); return(0); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/wsle.c0000644000175000017500000000127111236375625014041 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "fmt.h" #include "lio.h" #include "string.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers integer s_wsle(a) cilist *a; #else integer s_wsle(cilist *a) #endif { int n; if(n=c_le(a)) return(n); f__reading=0; f__external=1; f__formatted=1; f__putn = x_putc; f__lioproc = l_write; L_len = LINE; f__donewrec = x_wSL; if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) err(a->cierr, errno, "list output start"); return(0); } integer e_wsle(Void) { int n = f__putbuf('\n'); f__recpos=0; #ifdef ALWAYS_FLUSH if (!n && fflush(f__cf)) err(f__elist->cierr, errno, "write end"); #endif return(n); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/wsne.c0000644000175000017500000000073711236375625014051 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "lio.h" #ifdef __cplusplus extern "C" { #endif integer #ifdef KR_headers s_wsne(a) cilist *a; #else s_wsne(cilist *a) #endif { int n; if(n=c_le(a)) return(n); f__reading=0; f__external=1; f__formatted=1; f__putn = x_putc; L_len = LINE; f__donewrec = x_wSL; if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) err(a->cierr, errno, "namelist output start"); x_wsne(a); return e_wsle(); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/xsum0.out0000644000175000017500000000755111236376510014531 0ustar afrb2afrb2Notice 76f23b4 1212 README 16a3882f 16876 abort_.c f51c808 304 arithchk.c fae7c666 5171 backspac.c 10ebf554 1328 c_abs.c fec22c59 272 c_cos.c 18fc0ea3 354 c_div.c 1797c106 936 c_exp.c 1b85b1fc 349 c_log.c 28cdfed 384 c_sin.c 1ccaedc8 350 c_sqrt.c f1ee88d5 605 cabs.c f3d3b5f2 494 close.c 173f01de 1393 comptry.bat f8a8a0d5 125 ctype.c f553a125 40 ctype.h 1e54977d 1139 d_abs.c e58094ef 218 d_acos.c e5ecf93d 245 d_asin.c e12ceeff 245 d_atan.c 53034db 245 d_atn2.c ff8a1a78 271 d_cnjg.c 1c27c728 255 d_cos.c c0eb625 241 d_cosh.c 11dc4adb 245 d_dim.c e1ccb774 232 d_exp.c 1879c41c 241 d_imag.c fe9c703e 201 d_int.c f5de3566 269 d_lg10.c 1a1d7b77 291 d_log.c 1b368adf 241 d_mod.c f540cf24 688 d_nint.c ff913b40 281 d_prod.c ad4856b 207 d_sign.c 9562fc5 266 d_sin.c 6e3f542 241 d_sinh.c 18b22950 245 d_sqrt.c 17e1db09 245 d_tan.c ec93ebdb 241 d_tanh.c 1c55d15b 245 derf_.c f85e74a3 239 derfc_.c e96b7667 253 dfe.c 1d658105 2624 dolio.c 19c9fbd9 471 dtime_.c c982be4 972 due.c ee219f6d 1624 ef1asc_.c e0576e63 521 ef1cmc_.c ea5ad9e8 427 endfile.c 6f7201d 2838 erf_.c e82f7790 270 erfc_.c ba65441 275 err.c e59d1707 6442 etime_.c 19d1fdad 839 exit_.c ff4baa3a 543 f2c.h0 e770b7d8 4688 f2ch.add ef66bf17 6060 f77_aloc.c f8daf96e 684 f77vers.c ed1c96fa 4933 fio.h e41d245e 2939 fmt.c f9a1bb94 8566 fmt.h ec84ce17 2006 fmtlib.c eefc6a27 865 fp.h 100fb355 665 ftell_.c 78218d 900 ftell64_.c e2c4b21e 917 getarg_.c fd514f59 592 getenv_.c f4b06e2 1223 h_abs.c e4443109 218 h_dim.c c6e48bc 230 h_dnnt.c f6bb90e 294 h_indx.c ef8461eb 442 h_len.c e8c3633 205 h_mod.c 7355bd0 207 h_nint.c f0da3396 281 h_sign.c f1370ffd 266 hl_ge.c ed792501 346 hl_gt.c feeacbd9 345 hl_le.c f6fb5d6e 346 hl_lt.c 18501419 345 i77vers.c f57b8ef2 18128 i_abs.c 12ab51ab 214 i_dim.c f2a56785 225 i_dnnt.c 11748482 291 i_indx.c fb59026f 430 i_len.c 17d17252 203 i_mod.c bef73ae 211 i_nint.c e494b804 278 i_sign.c fa015b08 260 iargc_.c 49abda3 196 iio.c f958b627 2639 ilnw.c fe0ab14b 1125 inquire.c 1883d542 2732 l_ge.c f4710e74 334 l_gt.c e8db94a7 333 l_le.c c9c0a99 334 l_lt.c 767e79f 333 lbitbits.c 33fe981 1097 lbitshft.c e81981d2 258 libf2c.lbc 10af591e 1594 libf2c.sy fd5f568f 2051 lio.h 805735d 1564 lread.c f1e54a1f 14739 lwrite.c f80da63f 4616 main.c 371f60f 2230 makefile.sy 174ccb83 2990 makefile.u fce2cb5f 7302 makefile.vc 179d7b1c 2942 makefile.wat 18b044ac 2936 math.hvc 19bb2d07 50 mkfile.plan9 e67e471e 5174 open.c e7bcc295 5701 pow_ci.c fa934cec 412 pow_dd.c f004559b 276 pow_di.c a4db539 448 pow_hh.c d1a45a9 489 pow_ii.c 1fcf2742 488 pow_qq.c e6a32de6 516 pow_ri.c e7d9fc2a 436 pow_zi.c 1b894af7 851 pow_zz.c f81a06b5 549 qbitbits.c fdb9910e 1151 qbitshft.c 873054d 258 r_abs.c f471383c 206 r_acos.c 1a6aca63 233 r_asin.c e8555587 233 r_atan.c eac25444 233 r_atn2.c f611bea 253 r_cnjg.c a8d7805 235 r_cos.c fdef1ece 229 r_cosh.c f05d1ae 233 r_dim.c ee23e1a8 214 r_exp.c 1da16cd7 229 r_imag.c 166ad0f3 189 r_int.c fc80b9a8 257 r_lg10.c e876cfab 279 r_log.c 2062254 229 r_mod.c 187363fc 678 r_nint.c 6edcbb2 269 r_sign.c 1ae32441 248 r_sin.c c3d968 229 r_sinh.c 1090c850 233 r_sqrt.c ffbb0625 233 r_tan.c fe85179d 229 r_tanh.c 10ffcc5b 233 rawio.h 1ab49f7c 718 rdfmt.c 7222fee 8925 rewind.c e4c6236f 475 rsfe.c eb9e882c 1492 rsli.c 11f59b61 1785 rsne.c fea7e5be 11585 s_cat.c 164a6ff1 1458 s_cmp.c e69e8b60 722 s_copy.c 1e258852 1024 s_paus.c e37cfe6 1617 s_rnge.c e8cf83a3 759 s_stop.c ffa80b24 762 scomptry.bat ed740ad8 181 sfe.c 1e10bda3 828 sig_die.c 12eb0eac 689 signal1.h0 1d43ee57 842 signal_.c f3ef9cfc 299 signbit.c e37eac06 330 sue.c 9705ecf 1865 sysdep1.h0 1812022d 1202 system_.c ff72e46c 652 typesize.c eee307ae 386 uio.c e354a770 1619 uninit.c fe760fb0 7584 util.c 172fa76e 972 wref.c 17bbfb7b 4747 wrtfmt.c 113fc4f9 7506 wsfe.c f2d1fe4d 1280 wsle.c fe50b4c9 697 wsne.c 428bfda 479 xwsne.c 185c4bdc 1174 z_abs.c 1fa0640d 268 z_cos.c facccd9b 363 z_div.c e6f03676 913 z_exp.c 1a8506e8 357 z_log.c 6bf3b22 2729 z_sin.c 1aa35b59 359 z_sqrt.c 1864d867 581 libf2c2-20090411.orig/xwsne.c0000644000175000017500000000222611236375625014234 0ustar afrb2afrb2#include "f2c.h" #include "fio.h" #include "lio.h" #include "fmt.h" extern int f__Aquote; static VOID nl_donewrec(Void) { (*f__donewrec)(); PUT(' '); } #ifdef KR_headers x_wsne(a) cilist *a; #else #include "string.h" #ifdef __cplusplus extern "C" { #endif VOID x_wsne(cilist *a) #endif { Namelist *nl; char *s; Vardesc *v, **vd, **vde; ftnint number, type; ftnlen *dims; ftnlen size; extern ftnlen f__typesize[]; nl = (Namelist *)a->cifmt; PUT('&'); for(s = nl->name; *s; s++) PUT(*s); PUT(' '); f__Aquote = 1; vd = nl->vars; vde = vd + nl->nvars; while(vd < vde) { v = *vd++; s = v->name; #ifdef No_Extra_Namelist_Newlines if (f__recpos+strlen(s)+2 >= L_len) #endif nl_donewrec(); while(*s) PUT(*s++); PUT(' '); PUT('='); number = (dims = v->dims) ? dims[1] : 1; type = v->type; if (type < 0) { size = -type; type = TYCHAR; } else size = f__typesize[type]; l_write(&number, v->addr, size, type); if (vd < vde) { if (f__recpos+2 >= L_len) nl_donewrec(); PUT(','); PUT(' '); } else if (f__recpos+1 >= L_len) nl_donewrec(); } f__Aquote = 0; PUT('/'); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/z_abs.c0000644000175000017500000000041411236375625014163 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #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 ) ); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/z_cos.c0000644000175000017500000000055311236375625014206 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sin(), cos(), sinh(), cosh(); VOID z_cos(r, z) doublecomplex *r, *z; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif void z_cos(doublecomplex *r, doublecomplex *z) #endif { double zi = z->i, zr = z->r; r->r = cos(zr) * cosh(zi); r->i = - sin(zr) * sinh(zi); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/z_div.c0000644000175000017500000000162111236375625014201 0ustar afrb2afrb2#include "f2c.h" #ifdef __cplusplus extern "C" { #endif #ifdef KR_headers extern VOID sig_die(); VOID z_div(c, a, b) doublecomplex *a, *b, *c; #else extern void sig_die(const char*, int); void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) #endif { double ratio, den; double abr, abi, cr; if( (abr = b->r) < 0.) abr = - abr; if( (abi = b->i) < 0.) abi = - abi; if( abr <= abi ) { if(abi == 0) { #ifdef IEEE_COMPLEX_DIVIDE if (a->i != 0 || a->r != 0) abi = 1.; c->i = c->r = abi / abr; return; #else sig_die("complex division by zero", 1); #endif } ratio = b->r / b->i ; den = b->i * (1 + ratio*ratio); cr = (a->r*ratio + a->i) / den; c->i = (a->i*ratio - a->r) / den; } else { ratio = b->i / b->r ; den = b->r * (1 + ratio*ratio); cr = (a->r + a->i*ratio) / den; c->i = (a->i - a->r*ratio) / den; } c->r = cr; } #ifdef __cplusplus } #endif libf2c2-20090411.orig/z_exp.c0000644000175000017500000000054511236375625014217 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double exp(), cos(), sin(); VOID z_exp(r, z) doublecomplex *r, *z; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif void z_exp(doublecomplex *r, doublecomplex *z) #endif { double expx, zi = z->i; expx = exp(z->r); r->r = expx * cos(zi); r->i = expx * sin(zi); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/z_log.c0000644000175000017500000000525111236375625014203 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double log(), f__cabs(), atan2(); #define ANSI(x) () #else #define ANSI(x) x #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif extern double f__cabs(double, double); #endif #ifndef NO_DOUBLE_EXTENDED #ifndef GCC_COMPARE_BUG_FIXED #ifndef Pre20000310 #ifdef Comment Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3: on IA32 (Intel 80x87) systems, they may do comparisons on values computed in extended-precision registers. This can lead to the test "s > s0" that was used below being carried out incorrectly. The fix below cannot be spoiled by overzealous optimization, since the compiler cannot know whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always to be zero. The weird name is unlikely to collide with anything.) An example (provided by Ulrich Jakobus) where the bug fix matters is double complex a, b a = (.1099557428756427618354862829619, .9857360542953131909982289471372) b = log(a) An alternative to the fix below would be to use 53-bit rounding precision, but the means of specifying this 80x87 feature are highly unportable. #endif /*Comment*/ #define BYPASS_GCC_COMPARE_BUG double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*)); static double #ifdef KR_headers diff1(a,b) double *a, *b; #else diff1(double *a, double *b) #endif { return *a - *b; } #endif /*Pre20000310*/ #endif /*GCC_COMPARE_BUG_FIXED*/ #endif /*NO_DOUBLE_EXTENDED*/ #ifdef KR_headers VOID z_log(r, z) doublecomplex *r, *z; #else void z_log(doublecomplex *r, doublecomplex *z) #endif { double s, s0, t, t2, u, v; double zi = z->i, zr = z->r; #ifdef BYPASS_GCC_COMPARE_BUG double (*diff) ANSI((double*,double*)); #endif r->i = atan2(zi, zr); #ifdef Pre20000310 r->r = log( f__cabs( zr, zi ) ); #else if (zi < 0) zi = -zi; if (zr < 0) zr = -zr; if (zr < zi) { t = zi; zi = zr; zr = t; } t = zi/zr; s = zr * sqrt(1 + t*t); /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */ if ((t = s - 1) < 0) t = -t; if (t > .01) r->r = log(s); else { #ifdef Comment log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ... = x(1 - x/2 + x^2/3 -+...) [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1] #endif /*Comment*/ #ifdef BYPASS_GCC_COMPARE_BUG if (!(diff = gcc_bug_bypass_diff_F2C)) diff = diff1; #endif t = ((zr*zr - 1.) + zi*zi) / (s + 1); t2 = t*t; s = 1. - 0.5*t; u = v = 1; do { s0 = s; u *= t2; v += 2; s += u/v - t*u/(v+1); } #ifdef BYPASS_GCC_COMPARE_BUG while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.); #else while(s > s0); #endif r->r = s*t; } #endif } #ifdef __cplusplus } #endif libf2c2-20090411.orig/z_sin.c0000644000175000017500000000054711236375625014216 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sin(), cos(), sinh(), cosh(); VOID z_sin(r, z) doublecomplex *r, *z; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif void z_sin(doublecomplex *r, doublecomplex *z) #endif { double zi = z->i, zr = z->r; r->r = sin(zr) * cosh(zi); r->i = cos(zr) * sinh(zi); } #ifdef __cplusplus } #endif libf2c2-20090411.orig/z_sqrt.c0000644000175000017500000000110511236375625014405 0ustar afrb2afrb2#include "f2c.h" #ifdef KR_headers double sqrt(), f__cabs(); VOID z_sqrt(r, z) doublecomplex *r, *z; #else #undef abs #include "math.h" #ifdef __cplusplus extern "C" { #endif extern double f__cabs(double, double); void z_sqrt(doublecomplex *r, doublecomplex *z) #endif { double mag, zi = z->i, zr = z->r; if( (mag = f__cabs(zr, zi)) == 0.) r->r = r->i = 0.; else if(zr > 0) { r->r = sqrt(0.5 * (mag + zr) ); r->i = zi / r->r / 2; } else { r->i = sqrt(0.5 * (mag - zr) ); if(zi < 0) r->i = - r->i; r->r = zi / r->i / 2; } } #ifdef __cplusplus } #endif