Upgrade to the 1997/02/26 version.
This commit is contained in:
parent
8609d4594f
commit
4ff323dd45
@ -23,7 +23,7 @@ F77_aloc(integer Len, char *whence)
|
||||
char *rv;
|
||||
unsigned int uLen = (unsigned int) Len; /* for K&R C */
|
||||
|
||||
if (!(rv = malloc(uLen))) {
|
||||
if (!(rv = (char*)malloc(uLen))) {
|
||||
fprintf(stderr, "malloc(%u) failure in %s\n",
|
||||
uLen, whence);
|
||||
exit_(&memfailure);
|
||||
|
@ -31,7 +31,7 @@ To check for transmission errors, issue the command
|
||||
This assumes you have the xsum program whose source, xsum.c,
|
||||
is distributed as part of "all from f2c/src". If you do not
|
||||
have xsum, you can obtain xsum.c by sending the following E-mail
|
||||
message to netlib@research.att.com
|
||||
message to netlib@netlib.bell-labs.com
|
||||
send xsum.c from f2c/src
|
||||
|
||||
The makefile assumes you have installed f2c.h in a standard
|
||||
@ -82,10 +82,11 @@ external Fortran routines.
|
||||
cmd to the system's command processor (on systems where
|
||||
this can be done).
|
||||
|
||||
The makefile does not attempt to compile pow_qq.c, which is meant
|
||||
for use with INTEGER*8. To use it, you must modify f2c.h to
|
||||
declare longint appropriately; then add pow_qq.o to the POW =
|
||||
line in the makefile.
|
||||
The makefile does not attempt to compile pow_qq.c, qbitbits.c,
|
||||
and qbitshft.c, which are meant for use with INTEGER*8. To use
|
||||
INTEGER*8, you must modify f2c.h to declare longint and ulongint
|
||||
appropriately; then add pow_qq.o to the POW = line in the makefile,
|
||||
and add " qbitbits.o qbitshft.o" to the makefile's F90BIT = line.
|
||||
|
||||
Following Fortran 90, s_cat.c and s_copy.c allow the target of a
|
||||
(character string) assignment to be appear on its right-hand, at
|
||||
@ -94,3 +95,14 @@ If you prefer the extra efficiency that comes with the Fortran 77
|
||||
requirement that the left-hand side of a character assignment not
|
||||
be involved in the right-hand side, compile s_cat.c and s_copy.c
|
||||
with -DNO_OVERWRITE .
|
||||
|
||||
If your system lacks a ranlib command, you don't need it.
|
||||
Either comment out the makefile's ranlib invocation, or install
|
||||
a harmless "ranlib" command somewhere in your PATH, such as the
|
||||
one-line shell script
|
||||
|
||||
exit 0
|
||||
|
||||
or (on some systems)
|
||||
|
||||
exec /usr/bin/ar lts $1 >/dev/null
|
||||
|
@ -1,4 +1,4 @@
|
||||
static char junk[] = "\n@(#)LIBF77 VERSION 2.01 6 Sept. 1995\n";
|
||||
static char junk[] = "\n@(#)LIBF77 VERSION 19970226\n";
|
||||
|
||||
/*
|
||||
2.00 11 June 1980. File version.c added to library.
|
||||
@ -38,4 +38,12 @@ static char junk[] = "\n@(#)LIBF77 VERSION 2.01 6 Sept. 1995\n";
|
||||
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.)
|
||||
*/
|
||||
|
@ -12,5 +12,7 @@ int abort_(void)
|
||||
#endif
|
||||
{
|
||||
sig_die("Fortran abort routine called", 1);
|
||||
#ifdef __cplusplus
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
@ -11,6 +11,7 @@ VOID c_cos(r, z) complex *r, *z;
|
||||
void c_cos(complex *r, complex *z)
|
||||
#endif
|
||||
{
|
||||
r->r = cos(z->r) * cosh(z->i);
|
||||
r->i = - sin(z->r) * sinh(z->i);
|
||||
}
|
||||
double zr = z->r;
|
||||
r->r = cos(zr) * cosh(z->i);
|
||||
r->i = - sin(zr) * sinh(z->i);
|
||||
}
|
||||
|
@ -9,28 +9,29 @@ extern void sig_die(char*,int);
|
||||
void c_div(complex *c, complex *a, complex *b)
|
||||
#endif
|
||||
{
|
||||
double ratio, den;
|
||||
double abr, abi;
|
||||
double ratio, den;
|
||||
double abr, abi;
|
||||
double ai = a->i, ar = a->r, bi = b->i, br = b->r;
|
||||
|
||||
if( (abr = b->r) < 0.)
|
||||
abr = - abr;
|
||||
if( (abi = b->i) < 0.)
|
||||
abi = - abi;
|
||||
if( abr <= abi )
|
||||
{
|
||||
if(abi == 0)
|
||||
sig_die("complex division by zero", 1);
|
||||
ratio = (double)b->r / b->i ;
|
||||
den = b->i * (1 + ratio*ratio);
|
||||
c->r = (a->r*ratio + a->i) / den;
|
||||
c->i = (a->i*ratio - a->r) / den;
|
||||
}
|
||||
if( (abr = br) < 0.)
|
||||
abr = - abr;
|
||||
if( (abi = bi) < 0.)
|
||||
abi = - abi;
|
||||
if( abr <= abi )
|
||||
{
|
||||
if(abi == 0)
|
||||
sig_die("complex division by zero", 1);
|
||||
ratio = (double)br / bi ;
|
||||
den = bi * (1 + ratio*ratio);
|
||||
c->r = (ar*ratio + ai) / den;
|
||||
c->i = (ai*ratio - ar) / den;
|
||||
}
|
||||
|
||||
else
|
||||
{
|
||||
ratio = (double)b->i / b->r ;
|
||||
den = b->r * (1 + ratio*ratio);
|
||||
c->r = (a->r + a->i*ratio) / den;
|
||||
c->i = (a->i - a->r*ratio) / den;
|
||||
else
|
||||
{
|
||||
ratio = (double)bi / br ;
|
||||
den = br * (1 + ratio*ratio);
|
||||
c->r = (ar + ai*ratio) / den;
|
||||
c->i = (ai - ar*ratio) / den;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -11,6 +11,7 @@ extern double f__cabs(double, double);
|
||||
void c_log(complex *r, complex *z)
|
||||
#endif
|
||||
{
|
||||
r->i = atan2(z->i, z->r);
|
||||
r->r = log( f__cabs(z->r, z->i) );
|
||||
}
|
||||
double zi;
|
||||
r->i = atan2(zi = z->i, z->r);
|
||||
r->r = log( f__cabs(z->r, zi) );
|
||||
}
|
||||
|
@ -11,6 +11,7 @@ VOID c_sin(r, z) complex *r, *z;
|
||||
void c_sin(complex *r, complex *z)
|
||||
#endif
|
||||
{
|
||||
r->r = sin(z->r) * cosh(z->i);
|
||||
r->i = cos(z->r) * sinh(z->i);
|
||||
}
|
||||
double zr = z->r;
|
||||
r->r = sin(zr) * cosh(z->i);
|
||||
r->i = cos(zr) * sinh(z->i);
|
||||
}
|
||||
|
@ -12,23 +12,24 @@ extern double f__cabs(double, double);
|
||||
void c_sqrt(complex *r, complex *z)
|
||||
#endif
|
||||
{
|
||||
double mag, t;
|
||||
double mag, t;
|
||||
double zi = z->i, zr = z->r;
|
||||
|
||||
if( (mag = f__cabs(z->r, z->i)) == 0.)
|
||||
r->r = r->i = 0.;
|
||||
else if(z->r > 0)
|
||||
{
|
||||
r->r = t = sqrt(0.5 * (mag + z->r) );
|
||||
t = z->i / t;
|
||||
r->i = 0.5 * t;
|
||||
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;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
t = sqrt(0.5 * (mag - z->r) );
|
||||
if(z->i < 0)
|
||||
t = -t;
|
||||
r->i = t;
|
||||
t = z->i / t;
|
||||
r->r = 0.5 * t;
|
||||
}
|
||||
}
|
||||
|
@ -8,12 +8,14 @@
|
||||
|
||||
#ifdef KR_headers
|
||||
extern VOID s_copy();
|
||||
int ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
|
||||
ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
|
||||
#else
|
||||
extern void s_copy(char*,char*,ftnlen,ftnlen);
|
||||
int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb)
|
||||
#endif
|
||||
{
|
||||
s_copy( (char *)a, (char *)b, EVEN(*la), *lb );
|
||||
#ifdef __cplusplus
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
@ -1,37 +0,0 @@
|
||||
/* This gives the effect of
|
||||
|
||||
subroutine exit(rc)
|
||||
integer*4 rc
|
||||
stop
|
||||
end
|
||||
|
||||
* with the added side effect of supplying rc as the program's exit code.
|
||||
*/
|
||||
|
||||
#include "f2c.h"
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#ifndef KR_headers
|
||||
#include "stdlib.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
extern void f_exit(void);
|
||||
#endif
|
||||
|
||||
void
|
||||
#ifdef KR_headers
|
||||
exit_(rc) integer *rc;
|
||||
#else
|
||||
exit_(integer *rc)
|
||||
#endif
|
||||
{
|
||||
#ifdef NO_ONEXIT
|
||||
f_exit();
|
||||
#endif
|
||||
exit(*rc);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
@ -150,7 +150,7 @@ extern integer s_wsni(icilist *);
|
||||
extern integer s_wsue(cilist *);
|
||||
extern void sig_die(char *, int);
|
||||
extern integer signal_(integer *, void (*)(int));
|
||||
extern int system_(char *, ftnlen);
|
||||
extern integer system_(char *, ftnlen);
|
||||
extern double z_abs(doublecomplex *);
|
||||
extern void z_cos(doublecomplex *, doublecomplex *);
|
||||
extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
|
||||
|
@ -30,7 +30,7 @@ for(fp = fname ; fp < flast ; ++fp)
|
||||
break;
|
||||
}
|
||||
|
||||
while ( (ep = *env++) )
|
||||
while (ep = *env++)
|
||||
{
|
||||
for(fp = fname; fp<flast ; )
|
||||
if(*fp++ != *ep++)
|
||||
|
62
lib/libF77/lbitbits.c
Normal file
62
lib/libF77/lbitbits.c
Normal file
@ -0,0 +1,62 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifndef LONGBITS
|
||||
#define LONGBITS 32
|
||||
#endif
|
||||
|
||||
integer
|
||||
#ifdef KR_headers
|
||||
lbit_bits(a, b, len) integer a, b, len;
|
||||
#else
|
||||
lbit_bits(integer a, integer b, integer len)
|
||||
#endif
|
||||
{
|
||||
/* Assume 2's complement arithmetic */
|
||||
|
||||
unsigned long x, y;
|
||||
|
||||
x = (unsigned long) a;
|
||||
y = (unsigned long)-1L;
|
||||
x >>= b;
|
||||
y <<= len;
|
||||
return (integer)(x & ~y);
|
||||
}
|
||||
|
||||
integer
|
||||
#ifdef KR_headers
|
||||
lbit_cshift(a, b, len) integer a, b, len;
|
||||
#else
|
||||
lbit_cshift(integer a, integer b, integer len)
|
||||
#endif
|
||||
{
|
||||
unsigned long x, y, z;
|
||||
|
||||
x = (unsigned long)a;
|
||||
if (len <= 0) {
|
||||
if (len == 0)
|
||||
return 0;
|
||||
goto full_len;
|
||||
}
|
||||
if (len >= LONGBITS) {
|
||||
full_len:
|
||||
if (b >= 0) {
|
||||
b %= LONGBITS;
|
||||
return (integer)(x << b | x >> LONGBITS -b );
|
||||
}
|
||||
b = -b;
|
||||
b %= LONGBITS;
|
||||
return (integer)(x << LONGBITS - b | x >> b);
|
||||
}
|
||||
y = z = (unsigned long)-1;
|
||||
y <<= len;
|
||||
z &= ~y;
|
||||
y &= x;
|
||||
x &= z;
|
||||
if (b >= 0) {
|
||||
b %= len;
|
||||
return (integer)(y | z & (x << b | x >> len - b));
|
||||
}
|
||||
b = -b;
|
||||
b %= len;
|
||||
return (integer)(y | z & (x >> b | x << len - b));
|
||||
}
|
11
lib/libF77/lbitshft.c
Normal file
11
lib/libF77/lbitshft.c
Normal file
@ -0,0 +1,11 @@
|
||||
#include "f2c.h"
|
||||
|
||||
integer
|
||||
#ifdef KR_headers
|
||||
lbit_shift(a, b) integer a; integer b;
|
||||
#else
|
||||
lbit_shift(integer a, integer b)
|
||||
#endif
|
||||
{
|
||||
return b >= 0 ? a << b : (integer)((uinteger)a >> -b);
|
||||
}
|
@ -1,120 +0,0 @@
|
||||
F77_aloc.c fc8e8844 536
|
||||
Notice 1211689a 1195
|
||||
README 1d306d9d 4130
|
||||
Version.c f329c4b2 2060
|
||||
abort_.c eaf90dc0 239
|
||||
c_abs.c ecce7a47 205
|
||||
c_cos.c f2338a46 260
|
||||
c_div.c f780c50e 665
|
||||
c_exp.c e1b005d5 270
|
||||
c_log.c 4050533 292
|
||||
c_sin.c f19855c9 258
|
||||
c_sqrt.c 4e1ad71 505
|
||||
cabs.c abac46c 427
|
||||
d_abs.c ed70186c 151
|
||||
d_acos.c e5d8cdee 178
|
||||
d_asin.c f1c92f52 178
|
||||
d_atan.c fe8cfd3f 178
|
||||
d_atn2.c fa5f66a9 204
|
||||
d_cnjg.c 16aaf72f 165
|
||||
d_cos.c f37be16 174
|
||||
d_cosh.c a2f7dcf 178
|
||||
d_dim.c 1dfe4b39 165
|
||||
d_exp.c fb0efb6d 174
|
||||
d_imag.c ff9da248 134
|
||||
d_int.c e10c5fc2 202
|
||||
d_lg10.c 1381342c 224
|
||||
d_log.c ec2a8447 174
|
||||
d_mod.c e30684f1 621
|
||||
d_nint.c ffa7895c 214
|
||||
d_prod.c e3b5d46a 140
|
||||
d_sign.c 1782063b 199
|
||||
d_sin.c ef24638e 174
|
||||
d_sinh.c e0ec938a 178
|
||||
d_sqrt.c 1ff988eb 178
|
||||
d_tan.c ffc9a88e 174
|
||||
d_tanh.c e5e0cbbd 178
|
||||
derf_.c fdf1917c 172
|
||||
derfc_.c 4cb5ea3 186
|
||||
ef1asc_.c f14b3469 453
|
||||
ef1cmc_.c 1e0b86e3 360
|
||||
erf_.c 7a407d 158
|
||||
erfc_.c fb488e22 163
|
||||
exit.c eaf1e4de 476
|
||||
f2ch.add fed3bb7b 6056
|
||||
getarg_.c edcf61f8 495
|
||||
getenv_.c eaafcc11 975
|
||||
h_abs.c 8383aa6 151
|
||||
h_dim.c 9f9a693 163
|
||||
h_dnnt.c d754cc8 218
|
||||
h_indx.c 145ff2e8 375
|
||||
h_len.c e85aa13f 138
|
||||
h_mod.c feacad2a 140
|
||||
h_nint.c eb54a855 206
|
||||
h_sign.c e7d69d03 199
|
||||
hl_ge.c 26bca46 279
|
||||
hl_gt.c f5426c57 278
|
||||
hl_le.c ff67a970 279
|
||||
hl_lt.c f8842102 278
|
||||
i_abs.c f6c3045e 147
|
||||
i_dim.c ae23de2 158
|
||||
i_dnnt.c e0c7e5e4 216
|
||||
i_indx.c 19177d0c 363
|
||||
i_len.c e32e1f92 136
|
||||
i_mod.c 8bb577c 144
|
||||
i_nint.c e0a366e8 204
|
||||
i_sign.c 1f26e421 193
|
||||
iargc_.c 324b252 129
|
||||
l_ge.c 5b7cb55 267
|
||||
l_gt.c ad1b388 266
|
||||
l_le.c f5407149 267
|
||||
l_lt.c f81a93f8 266
|
||||
main.c 1144a505 2064
|
||||
makefile e4156396 3063
|
||||
pow_ci.c f593b0b9 345
|
||||
pow_dd.c e451857d 209
|
||||
pow_di.c 11a1842e 381
|
||||
pow_hh.c e0cb1b69 422
|
||||
pow_ii.c 17c60a01 421
|
||||
pow_qq.c ffbbdec9 449
|
||||
pow_ri.c eacf8350 369
|
||||
pow_zi.c fe9073e4 715
|
||||
pow_zz.c f0e5f141 482
|
||||
r_abs.c 1a4e3da 139
|
||||
r_acos.c ca67f96 166
|
||||
r_asin.c 188a2306 166
|
||||
r_atan.c fadda9d5 166
|
||||
r_atn2.c e97a5392 186
|
||||
r_cnjg.c f1c1fd80 151
|
||||
r_cos.c f19d771e 162
|
||||
r_cosh.c e20187a0 166
|
||||
r_dim.c ef5e869 147
|
||||
r_exp.c 18979beb 162
|
||||
r_imag.c e45086cf 122
|
||||
r_int.c f2c2f39c 190
|
||||
r_lg10.c 1279226d 212
|
||||
r_log.c 2682a0d 162
|
||||
r_mod.c f28ec59a 611
|
||||
r_nint.c 69d11bb 202
|
||||
r_sign.c eddb76f9 181
|
||||
r_sin.c 10007227 162
|
||||
r_sinh.c f21a38b8 166
|
||||
r_sqrt.c f24b8aa4 166
|
||||
r_tan.c e60b7778 162
|
||||
r_tanh.c f22ec5c 166
|
||||
s_cat.c 151033e2 1304
|
||||
s_cmp.c ff4f2982 655
|
||||
s_copy.c e10dd76f 957
|
||||
s_paus.c e726a719 1552
|
||||
s_rnge.c 1d6cada2 680
|
||||
s_stop.c 1f5aaac8 511
|
||||
sig_die.c e934624a 634
|
||||
signal_.c fde97f5f 395
|
||||
system_.c e4ed54ab 579
|
||||
z_abs.c f71a28c1 201
|
||||
z_cos.c 110bc444 269
|
||||
z_div.c ff56b823 675
|
||||
z_exp.c ced892b 278
|
||||
z_log.c 4ea97f4 305
|
||||
z_sin.c 1215f0b4 267
|
||||
z_sqrt.c e8d24b0 492
|
@ -1,7 +1,7 @@
|
||||
/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */
|
||||
|
||||
#include "stdio.h"
|
||||
#include "signal.h"
|
||||
#include "signal1.h"
|
||||
|
||||
#ifndef SIGIOT
|
||||
#ifdef SIGABRT
|
||||
@ -90,7 +90,10 @@ sig_die("Trace trap", 1);
|
||||
int xargc;
|
||||
char **xargv;
|
||||
|
||||
int
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
main(argc, argv) int argc; char **argv;
|
||||
#else
|
||||
@ -99,20 +102,20 @@ main(int argc, char **argv)
|
||||
{
|
||||
xargc = argc;
|
||||
xargv = argv;
|
||||
signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
|
||||
signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
|
||||
#ifdef SIGIOT
|
||||
signal(SIGIOT, sigidie);
|
||||
signal1(SIGIOT, sigidie);
|
||||
#endif
|
||||
#ifdef SIGTRAP
|
||||
signal(SIGTRAP, sigtrdie);
|
||||
signal1(SIGTRAP, sigtrdie);
|
||||
#endif
|
||||
#ifdef SIGQUIT
|
||||
if(signal(SIGQUIT,sigqdie) == SIG_IGN)
|
||||
signal(SIGQUIT, SIG_IGN);
|
||||
if(signal1(SIGQUIT,sigqdie) == SIG_IGN)
|
||||
signal1(SIGQUIT, SIG_IGN);
|
||||
#endif
|
||||
if(signal(SIGINT, sigindie) == SIG_IGN)
|
||||
signal(SIGINT, SIG_IGN);
|
||||
signal(SIGTERM,sigtdie);
|
||||
if(signal1(SIGINT, sigindie) == SIG_IGN)
|
||||
signal1(SIGINT, SIG_IGN);
|
||||
signal1(SIGTERM,sigtdie);
|
||||
|
||||
#ifdef pdp11
|
||||
ldfps(01200); /* detect overflow as an exception */
|
||||
@ -130,6 +133,3 @@ 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
|
||||
|
@ -1,78 +0,0 @@
|
||||
.SUFFIXES: .c .o
|
||||
CC = cc
|
||||
SHELL = /bin/sh
|
||||
CFLAGS = -O
|
||||
|
||||
# If your system lacks onexit() and you are not using an
|
||||
# ANSI C compiler, then you should add -DNO_ONEXIT to CFLAGS,
|
||||
# e.g., by changing the above "CFLAGS =" line to
|
||||
# CFLAGS = -O -DNO_ONEXIT
|
||||
|
||||
# On at least some Sun systems, it is more appropriate to change the
|
||||
# "CFLAGS =" line to
|
||||
# CFLAGS = -O -Donexit=on_exit
|
||||
|
||||
# compile, then strip unnecessary symbols
|
||||
.c.o:
|
||||
$(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c
|
||||
ld -r -x -o $*.xxx $*.o
|
||||
mv $*.xxx $*.o
|
||||
|
||||
MISC = F77_aloc.o Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o \
|
||||
getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\
|
||||
derf_.o derfc_.o erf_.o erfc_.o sig_die.o exit.o
|
||||
POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o
|
||||
CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
|
||||
DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
|
||||
REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
|
||||
r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
|
||||
r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
|
||||
r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
|
||||
DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
|
||||
d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
|
||||
d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
|
||||
d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
|
||||
d_sqrt.o d_tan.o d_tanh.o
|
||||
INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o
|
||||
HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o
|
||||
CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o
|
||||
EFL = ef1asc_.o ef1cmc_.o
|
||||
CHAR = s_cat.o s_cmp.o s_copy.o
|
||||
|
||||
libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
|
||||
$(HALF) $(CMP) $(EFL) $(CHAR)
|
||||
ar r libF77.a $?
|
||||
ranlib libF77.a
|
||||
|
||||
Version.o: Version.c
|
||||
$(CC) -c Version.c
|
||||
|
||||
# To compile with C++, first "make f2c.h"
|
||||
f2c.h: f2ch.add
|
||||
cat /usr/include/f2c.h f2ch.add >f2c.h
|
||||
|
||||
install: libF77.a
|
||||
mv libF77.a /usr/lib
|
||||
|
||||
clean:
|
||||
rm -f libF77.a *.o
|
||||
|
||||
check:
|
||||
xsum Notice README F77_aloc.c Version.c abort_.c c_abs.c c_cos.c \
|
||||
c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \
|
||||
d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \
|
||||
d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \
|
||||
d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \
|
||||
derf_.c derfc_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c exit.c f2ch.add \
|
||||
getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \
|
||||
h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \
|
||||
i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c \
|
||||
i_sign.c iargc_.c l_ge.c l_gt.c l_le.c l_lt.c main.c makefile \
|
||||
pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c \
|
||||
pow_zi.c pow_zz.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \
|
||||
r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \
|
||||
r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \
|
||||
r_tan.c r_tanh.c s_cat.c s_cmp.c s_copy.c \
|
||||
s_paus.c s_rnge.c s_stop.c sig_die.c signal_.c system_.c \
|
||||
z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >zap
|
||||
cmp zap libF77.xsum && rm zap || diff libF77.xsum zap
|
@ -8,44 +8,47 @@ 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 x;
|
||||
static doublecomplex one = {1.0, 0.0};
|
||||
integer n;
|
||||
unsigned long u;
|
||||
double t;
|
||||
doublecomplex q, x;
|
||||
static doublecomplex one = {1.0, 0.0};
|
||||
|
||||
n = *b;
|
||||
p->r = 1;
|
||||
p->i = 0;
|
||||
n = *b;
|
||||
q.r = 1;
|
||||
q.i = 0;
|
||||
|
||||
if(n == 0)
|
||||
return;
|
||||
if(n < 0)
|
||||
{
|
||||
n = -n;
|
||||
z_div(&x, &one, a);
|
||||
}
|
||||
else
|
||||
{
|
||||
x.r = a->r;
|
||||
x.i = a->i;
|
||||
}
|
||||
|
||||
for(u = n; ; )
|
||||
{
|
||||
if(u & 01)
|
||||
if(n == 0)
|
||||
goto done;
|
||||
if(n < 0)
|
||||
{
|
||||
t = p->r * x.r - p->i * x.i;
|
||||
p->i = p->r * x.i + p->i * x.r;
|
||||
p->r = t;
|
||||
}
|
||||
if(u >>= 1)
|
||||
{
|
||||
t = x.r * x.r - x.i * x.i;
|
||||
x.i = 2 * x.r * x.i;
|
||||
x.r = t;
|
||||
n = -n;
|
||||
z_div(&x, &one, a);
|
||||
}
|
||||
else
|
||||
break;
|
||||
{
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
@ -12,6 +12,8 @@
|
||||
extern void free();
|
||||
extern void exit_();
|
||||
#else
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
extern char *F77_aloc(ftnlen, char*);
|
||||
#endif
|
||||
@ -49,7 +51,9 @@ s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll)
|
||||
}
|
||||
lp0 = lp;
|
||||
lp = lp1 = F77_aloc(L = ll, "s_cat");
|
||||
break;
|
||||
}
|
||||
lp1 = lp;
|
||||
#endif /* NO_OVERWRITE */
|
||||
for(i = 0 ; i < n ; ++i) {
|
||||
nc = ll;
|
||||
|
@ -12,7 +12,7 @@
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#include "signal.h"
|
||||
#include "signal1.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
@ -74,7 +74,7 @@ s_paus(char *s, ftnlen n)
|
||||
fprintf(stderr,
|
||||
"To resume execution, execute a kill -%d %d command\n",
|
||||
PAUSESIG, getpid() );
|
||||
signal(PAUSESIG, waitpause);
|
||||
signal1(PAUSESIG, waitpause);
|
||||
fflush(stderr);
|
||||
pause();
|
||||
#endif
|
||||
|
@ -20,5 +20,7 @@ fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", offset+1
|
||||
while((i = *varn) && i != ' ')
|
||||
putc(*varn++, stderr);
|
||||
sig_die(".", 1);
|
||||
#ifdef __cplusplus
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
25
lib/libF77/signal1.h
Normal file
25
lib/libF77/signal1.h
Normal file
@ -0,0 +1,25 @@
|
||||
/* You may need to adjust the definition of signal1 to supply a */
|
||||
/* cast to the correct argument type. This detail is system- and */
|
||||
/* compiler-dependent. The #define below assumes signal.h declares */
|
||||
/* type SIG_PF for the signal function's second argument. */
|
||||
|
||||
#include <signal.h>
|
||||
|
||||
#ifndef Sigret_t
|
||||
#define Sigret_t void
|
||||
#endif
|
||||
#ifndef Sigarg_t
|
||||
#ifdef KR_headers
|
||||
#define Sigarg_t
|
||||
#else
|
||||
#define Sigarg_t int
|
||||
#endif
|
||||
#endif /*Sigarg_t*/
|
||||
|
||||
#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */
|
||||
#define sig_pf SIG_PF
|
||||
#else
|
||||
typedef Sigret_t (*sig_pf)(Sigarg_t);
|
||||
#endif
|
||||
|
||||
#define signal1(a,b) signal(a,(sig_pf)b)
|
@ -1,21 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
typedef VOID (*sig_type)();
|
||||
extern sig_type signal();
|
||||
typedef int (*sig_proc)();
|
||||
typedef VOID (*sig_pf)();
|
||||
extern sig_pf signal();
|
||||
#define signal1 signal
|
||||
|
||||
ftnint signal_(sigp, proc) integer *sigp; sig_type proc;
|
||||
ftnint signal_(sigp, proc) integer *sigp; sig_pf proc;
|
||||
#else
|
||||
#include "signal.h"
|
||||
typedef void (*sig_type)(int);
|
||||
typedef int (*sig_proc)(int);
|
||||
#include "signal1.h"
|
||||
|
||||
ftnint signal_(integer *sigp, sig_proc proc)
|
||||
ftnint signal_(integer *sigp, sig_pf proc)
|
||||
#endif
|
||||
{
|
||||
int sig;
|
||||
sig = (int)*sigp;
|
||||
|
||||
return (ftnint)signal(sig, (sig_type)proc);
|
||||
return (ftnint)signal(sig, proc);
|
||||
}
|
||||
|
@ -9,6 +9,7 @@ VOID z_cos(r, z) doublecomplex *r, *z;
|
||||
void z_cos(doublecomplex *r, doublecomplex *z)
|
||||
#endif
|
||||
{
|
||||
r->r = cos(z->r) * cosh(z->i);
|
||||
r->i = - sin(z->r) * sinh(z->i);
|
||||
}
|
||||
double zr = z->r;
|
||||
r->r = cos(zr) * cosh(z->i);
|
||||
r->i = - sin(zr) * sinh(z->i);
|
||||
}
|
||||
|
@ -8,29 +8,29 @@ extern void sig_die(char*, int);
|
||||
void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b)
|
||||
#endif
|
||||
{
|
||||
double ratio, den;
|
||||
double abr, abi;
|
||||
double ratio, den;
|
||||
double abr, abi;
|
||||
double ai = a->i, ar = a->r, bi = b->i, br = b->r;
|
||||
|
||||
if( (abr = b->r) < 0.)
|
||||
abr = - abr;
|
||||
if( (abi = b->i) < 0.)
|
||||
abi = - abi;
|
||||
if( abr <= abi )
|
||||
{
|
||||
if(abi == 0)
|
||||
sig_die("complex division by zero", 1);
|
||||
ratio = b->r / b->i ;
|
||||
den = b->i * (1 + ratio*ratio);
|
||||
c->r = (a->r*ratio + a->i) / den;
|
||||
c->i = (a->i*ratio - a->r) / den;
|
||||
if( (abr = br) < 0.)
|
||||
abr = - abr;
|
||||
if( (abi = bi) < 0.)
|
||||
abi = - abi;
|
||||
if( abr <= abi )
|
||||
{
|
||||
if(abi == 0)
|
||||
sig_die("complex division by zero", 1);
|
||||
ratio = br / bi ;
|
||||
den = bi * (1 + ratio*ratio);
|
||||
c->r = (ar*ratio + ai) / den;
|
||||
c->i = (ai*ratio - ar) / den;
|
||||
}
|
||||
|
||||
else
|
||||
{
|
||||
ratio = bi / br ;
|
||||
den = br * (1 + ratio*ratio);
|
||||
c->r = (ar + ai*ratio) / den;
|
||||
c->i = (ai - ar*ratio) / den;
|
||||
}
|
||||
}
|
||||
|
||||
else
|
||||
{
|
||||
ratio = b->i / b->r ;
|
||||
den = b->r * (1 + ratio*ratio);
|
||||
c->r = (a->r + a->i*ratio) / den;
|
||||
c->i = (a->i - a->r*ratio) / den;
|
||||
}
|
||||
|
||||
}
|
||||
|
@ -10,7 +10,7 @@ extern double f__cabs(double, double);
|
||||
void z_log(doublecomplex *r, doublecomplex *z)
|
||||
#endif
|
||||
{
|
||||
|
||||
r->i = atan2(z->i, z->r);
|
||||
r->r = log( f__cabs( z->r, z->i ) );
|
||||
}
|
||||
double zi = z->i;
|
||||
r->i = atan2(zi, z->r);
|
||||
r->r = log( f__cabs( z->r, zi ) );
|
||||
}
|
||||
|
@ -9,6 +9,7 @@ VOID z_sin(r, z) doublecomplex *r, *z;
|
||||
void z_sin(doublecomplex *r, doublecomplex *z)
|
||||
#endif
|
||||
{
|
||||
r->r = sin(z->r) * cosh(z->i);
|
||||
r->i = cos(z->r) * sinh(z->i);
|
||||
}
|
||||
double zr = z->r;
|
||||
r->r = sin(zr) * cosh(z->i);
|
||||
r->i = cos(zr) * sinh(z->i);
|
||||
}
|
||||
|
@ -10,20 +10,20 @@ extern double f__cabs(double, double);
|
||||
void z_sqrt(doublecomplex *r, doublecomplex *z)
|
||||
#endif
|
||||
{
|
||||
double mag;
|
||||
double mag, zi = z->i, zr = z->r;
|
||||
|
||||
if( (mag = f__cabs(z->r, z->i)) == 0.)
|
||||
r->r = r->i = 0.;
|
||||
else if(z->r > 0)
|
||||
{
|
||||
r->r = sqrt(0.5 * (mag + z->r) );
|
||||
r->i = z->i / r->r / 2;
|
||||
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;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
r->i = sqrt(0.5 * (mag - z->r) );
|
||||
if(z->i < 0)
|
||||
r->i = - r->i;
|
||||
r->r = z->i / r->i / 2;
|
||||
}
|
||||
}
|
||||
|
@ -1,5 +1,5 @@
|
||||
/****************************************************************
|
||||
Copyright 1990 - 1995 by AT&T Bell Laboratories and Bellcore.
|
||||
Copyright 1990 - 1997 by AT&T Bell Laboratories and Bellcore.
|
||||
|
||||
Permission to use, copy, modify, and distribute this software
|
||||
and its documentation for any purpose and without fee is hereby
|
||||
|
@ -32,6 +32,9 @@ number of characters transmitted -- then insert the line
|
||||
|
||||
at the end of fmt.h . This is necessary with
|
||||
at least some versions of Sun and DEC 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
|
||||
@ -117,7 +120,7 @@ To check for transmission errors, issue the command
|
||||
This assumes you have the xsum program whose source, xsum.c,
|
||||
is distributed as part of "all from f2c/src". If you do not
|
||||
have xsum, you can obtain xsum.c by sending the following E-mail
|
||||
message to netlib@research.att.com
|
||||
message to netlib@netlib.bell-labs.com
|
||||
send xsum.c from f2c/src
|
||||
|
||||
The makefile assumes you have installed f2c.h in a standard
|
||||
@ -134,6 +137,10 @@ 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.
|
||||
@ -188,3 +195,31 @@ 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 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
|
||||
|
||||
Most of the routines in libI77 are support routines for Fortran
|
||||
I/O. There are a few exceptions, summarized below -- I/O related
|
||||
functions and subroutines that appear to your program as ordinary
|
||||
external Fortran routines.
|
||||
|
||||
1. CALL FLUSH flushes all buffers.
|
||||
|
||||
2. FTELL(i) is an INTEGER function that returns the current
|
||||
offset of Fortran unit i (or -1 if unit i is not open).
|
||||
|
||||
3. 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.
|
||||
|
@ -1,4 +1,4 @@
|
||||
static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19950907\n";
|
||||
static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19970226\n";
|
||||
|
||||
/*
|
||||
2.01 $ format added
|
||||
@ -95,7 +95,7 @@ wrtfmt.c:
|
||||
/* 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.
|
||||
/* 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);
|
||||
@ -222,3 +222,23 @@ wrtfmt.c:
|
||||
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. */
|
||||
|
@ -2,7 +2,6 @@
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
|
||||
int
|
||||
y_rsk(Void)
|
||||
{
|
||||
if(f__curunit->uend || f__curunit->url <= f__recpos
|
||||
@ -12,8 +11,6 @@ y_rsk(Void)
|
||||
} while(++f__recpos < f__curunit->url);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
y_getc(Void)
|
||||
{
|
||||
int ch;
|
||||
@ -33,10 +30,7 @@ y_getc(Void)
|
||||
return(-1);
|
||||
}
|
||||
err(f__elist->cierr,errno,"readingd");
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
#ifdef KR_headers
|
||||
y_putc(c)
|
||||
#else
|
||||
@ -50,8 +44,6 @@ y_putc(int c)
|
||||
err(f__elist->cierr,110,"dout");
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
y_rev(Void)
|
||||
{ /*what about work done?*/
|
||||
if(f__curunit->url==1 || f__recpos==f__curunit->url)
|
||||
@ -61,17 +53,11 @@ y_rev(Void)
|
||||
f__recpos=0;
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
y_err(Void)
|
||||
{
|
||||
err(f__elist->cierr, 110, "dfe");
|
||||
#ifdef __cplusplus
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
int
|
||||
y_newrec(Void)
|
||||
{
|
||||
if(f__curunit->url == 1 || f__recpos == f__curunit->url) {
|
||||
@ -85,7 +71,6 @@ y_newrec(Void)
|
||||
return(1);
|
||||
}
|
||||
|
||||
int
|
||||
#ifdef KR_headers
|
||||
c_dfe(a) cilist *a;
|
||||
#else
|
||||
@ -105,7 +90,9 @@ c_dfe(cilist *a)
|
||||
if(!f__curunit->ufmt) err(a->cierr,102,"dfe")
|
||||
if(!f__curunit->useek) err(a->cierr,104,"dfe")
|
||||
f__fmtbuf=a->cifmt;
|
||||
(void) fseek(f__cf,(long)f__curunit->url * (a->cirec-1),SEEK_SET);
|
||||
if(a->cirec <= 0)
|
||||
err(a->cierr,130,"dfe")
|
||||
fseek(f__cf,(long)f__curunit->url * (a->cirec-1),SEEK_SET);
|
||||
f__curunit->uend = 0;
|
||||
return(0);
|
||||
}
|
||||
@ -117,8 +104,8 @@ integer s_rdfe(cilist *a)
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
if( (n=c_dfe(a)) )return(n);
|
||||
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;
|
||||
@ -139,8 +126,8 @@ integer s_wdfe(cilist *a)
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
if( (n=c_dfe(a)) ) return(n);
|
||||
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 = y_putc;
|
||||
|
@ -1,7 +1,6 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
|
||||
int
|
||||
#ifdef KR_headers
|
||||
c_due(a) cilist *a;
|
||||
#else
|
||||
@ -20,7 +19,9 @@ c_due(cilist *a)
|
||||
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")
|
||||
(void) fseek(f__cf,(long)(a->cirec-1)*f__curunit->url,SEEK_SET);
|
||||
if(a->cirec <= 0)
|
||||
err(a->cierr,130,"due")
|
||||
fseek(f__cf,(long)(a->cirec-1)*f__curunit->url,SEEK_SET);
|
||||
f__curunit->uend = 0;
|
||||
return(0);
|
||||
}
|
||||
@ -31,8 +32,8 @@ integer s_rdue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if( (n=c_due(a)) ) return(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);
|
||||
@ -44,8 +45,8 @@ integer s_wdue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if( (n=c_due(a)) ) return(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);
|
||||
@ -54,7 +55,7 @@ integer e_rdue(Void)
|
||||
{
|
||||
if(f__curunit->url==1 || f__recpos==f__curunit->url)
|
||||
return(0);
|
||||
(void) fseek(f__cf,(long)(f__curunit->url-f__recpos),SEEK_CUR);
|
||||
fseek(f__cf,(long)(f__curunit->url-f__recpos),SEEK_CUR);
|
||||
if(ftell(f__cf)%f__curunit->url)
|
||||
err(f__elist->cierr,200,"syserr");
|
||||
return(0);
|
||||
|
@ -43,7 +43,7 @@ integer f_end(alist *a)
|
||||
(void) sprintf(nbuf,"fort.%ld",a->aunit);
|
||||
#ifdef NON_UNIX_STDIO
|
||||
{ FILE *tf;
|
||||
if ( (tf = fopen(nbuf, f__w_mode[0])) )
|
||||
if (tf = fopen(nbuf, f__w_mode[0]))
|
||||
fclose(tf);
|
||||
}
|
||||
#else
|
||||
@ -63,7 +63,7 @@ copy(from, len, to) char *from, *to; register long len;
|
||||
copy(FILE *from, register long len, FILE *to)
|
||||
#endif
|
||||
{
|
||||
int len1;
|
||||
int k, len1;
|
||||
char buf[BUFSIZ];
|
||||
|
||||
while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
|
||||
|
@ -21,6 +21,7 @@ extern char *malloc();
|
||||
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;
|
||||
char *f__fmtbuf;
|
||||
@ -39,7 +40,8 @@ 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*/
|
||||
int f__cursor,f__scale;
|
||||
int f__cursor, f__hiwater, f__scale;
|
||||
char *f__icptr;
|
||||
|
||||
/*error messages*/
|
||||
char *F_err[] =
|
||||
@ -73,14 +75,15 @@ char *F_err[] =
|
||||
"can't read file", /* 126 */
|
||||
"can't write file", /* 127 */
|
||||
"'new' file exists", /* 128 */
|
||||
"can't append to file" /* 129 */
|
||||
"can't append to file", /* 129 */
|
||||
"non-positive record number" /* 130 */
|
||||
};
|
||||
#define MAXERR (sizeof(F_err)/sizeof(char *)+100)
|
||||
|
||||
#ifdef KR_headers
|
||||
int f__canseek(f) FILE *f; /*SYSDEP*/
|
||||
f__canseek(f) FILE *f; /*SYSDEP*/
|
||||
#else
|
||||
int f__canseek(FILE *f) /*SYSDEP*/
|
||||
f__canseek(FILE *f) /*SYSDEP*/
|
||||
#endif
|
||||
{
|
||||
#ifdef NON_UNIX_STDIO
|
||||
@ -187,9 +190,9 @@ f_init(Void)
|
||||
p->uwrt=1;
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int f__nowreading(x) unit *x;
|
||||
f__nowreading(x) unit *x;
|
||||
#else
|
||||
int f__nowreading(unit *x)
|
||||
f__nowreading(unit *x)
|
||||
#endif
|
||||
{
|
||||
long loc;
|
||||
@ -210,9 +213,9 @@ int f__nowreading(unit *x)
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int f__nowwriting(x) unit *x;
|
||||
f__nowwriting(x) unit *x;
|
||||
#else
|
||||
int f__nowwriting(unit *x)
|
||||
f__nowwriting(unit *x)
|
||||
#endif
|
||||
{
|
||||
long loc;
|
||||
|
@ -150,7 +150,7 @@ extern integer s_wsni(icilist *);
|
||||
extern integer s_wsue(cilist *);
|
||||
extern void sig_die(char *, int);
|
||||
extern integer signal_(integer *, void (*)(int));
|
||||
extern int system_(char *, ftnlen);
|
||||
extern integer system_(char *, ftnlen);
|
||||
extern double z_abs(doublecomplex *);
|
||||
extern void z_cos(doublecomplex *, doublecomplex *);
|
||||
extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
|
||||
|
@ -80,8 +80,8 @@ 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))
|
||||
#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
|
||||
@ -99,4 +99,4 @@ extern int f__hiwater; /* so TL doesn't confuse us */
|
||||
#define EXT 7
|
||||
#define INT 8
|
||||
|
||||
#define buf_end(x) ((x)->_flag & _IONBF ? (x)->_ptr : (x)->_base + BUFSIZ)
|
||||
#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
|
||||
|
@ -40,9 +40,9 @@ char *ap_end(char *s)
|
||||
/*NOTREACHED*/ return 0;
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int op_gen(a,b,c,d)
|
||||
op_gen(a,b,c,d)
|
||||
#else
|
||||
int op_gen(int a, int b, int c, int d)
|
||||
op_gen(int a, int b, int c, int d)
|
||||
#endif
|
||||
{ struct syl *p= &f__syl[f__pc];
|
||||
if(f__pc>=SYLMX)
|
||||
@ -99,9 +99,9 @@ char *f_s(char *s, int curloc)
|
||||
return(s);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int ne_d(s,p) char *s,**p;
|
||||
ne_d(s,p) char *s,**p;
|
||||
#else
|
||||
int ne_d(char *s, char **p)
|
||||
ne_d(char *s, char **p)
|
||||
#endif
|
||||
{ int n,x,sign=0;
|
||||
struct syl *sp;
|
||||
@ -185,9 +185,9 @@ int ne_d(char *s, char **p)
|
||||
return(1);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int e_d(s,p) char *s,**p;
|
||||
e_d(s,p) char *s,**p;
|
||||
#else
|
||||
int e_d(char *s, char **p)
|
||||
e_d(char *s, char **p)
|
||||
#endif
|
||||
{ int i,im,n,w,d,e,found=0,x=0;
|
||||
char *sv=s;
|
||||
@ -333,9 +333,9 @@ char *f_list(char *s)
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
int pars_f(s) char *s;
|
||||
pars_f(s) char *s;
|
||||
#else
|
||||
int pars_f(char *s)
|
||||
pars_f(char *s)
|
||||
#endif
|
||||
{
|
||||
f__parenlvl=f__revloc=f__pc=0;
|
||||
@ -350,9 +350,9 @@ int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
|
||||
flag f__workdone, f__nonl;
|
||||
|
||||
#ifdef KR_headers
|
||||
int type_f(n)
|
||||
type_f(n)
|
||||
#else
|
||||
int type_f(int n)
|
||||
type_f(int n)
|
||||
#endif
|
||||
{
|
||||
switch(n)
|
||||
@ -476,8 +476,6 @@ loop: switch(type_f((p= &f__syl[f__pc])->op))
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
en_fio(Void)
|
||||
{ ftnint one=1;
|
||||
return(do_fio(&one,(char *)NULL,(ftnint)0));
|
||||
|
@ -45,7 +45,10 @@ typedef union
|
||||
} ufloat;
|
||||
typedef union
|
||||
{ short is;
|
||||
char ic;
|
||||
#ifndef KR_headers
|
||||
signed
|
||||
#endif
|
||||
char ic;
|
||||
integer il;
|
||||
#ifdef Allow_TYQUAD
|
||||
longint ili;
|
||||
|
@ -5,6 +5,8 @@
|
||||
#ifndef Allow_TYQUAD
|
||||
#undef longint
|
||||
#define longint long
|
||||
#undef ulongint
|
||||
#define ulongint unsigned long
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
@ -13,13 +15,17 @@ char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign;
|
||||
#else
|
||||
char *f__icvt(longint value, int *ndigit, int *sign, int base)
|
||||
#endif
|
||||
{ static char buf[MAXINTLENGTH+1];
|
||||
{
|
||||
static char buf[MAXINTLENGTH+1];
|
||||
register int i;
|
||||
ulongint uvalue;
|
||||
|
||||
if(value > 0)
|
||||
if(value > 0) {
|
||||
uvalue = value;
|
||||
*sign = 0;
|
||||
}
|
||||
else if (value < 0) {
|
||||
value = -value;
|
||||
uvalue = -value;
|
||||
*sign = 1;
|
||||
}
|
||||
else {
|
||||
@ -30,10 +36,10 @@ char *f__icvt(longint value, int *ndigit, int *sign, int base)
|
||||
}
|
||||
i = MAXINTLENGTH;
|
||||
do {
|
||||
buf[--i] = (value%base) + '0';
|
||||
value /= base;
|
||||
buf[--i] = (uvalue%base) + '0';
|
||||
uvalue /= base;
|
||||
}
|
||||
while(value > 0);
|
||||
while(uvalue > 0);
|
||||
*ndigit = MAXINTLENGTH - i;
|
||||
return &buf[i];
|
||||
}
|
||||
|
@ -6,8 +6,6 @@ char *f__icend;
|
||||
extern icilist *f__svic;
|
||||
int f__icnum;
|
||||
extern int f__hiwater;
|
||||
|
||||
int
|
||||
z_getc(Void)
|
||||
{
|
||||
if(f__recpos++ < f__svic->icirlen) {
|
||||
@ -17,9 +15,9 @@ z_getc(Void)
|
||||
return '\n';
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int z_putc(c)
|
||||
z_putc(c)
|
||||
#else
|
||||
int z_putc(int c)
|
||||
z_putc(int c)
|
||||
#endif
|
||||
{
|
||||
if(f__icptr >= f__icend) err(f__svic->icierr,110,"inwrite");
|
||||
@ -28,8 +26,6 @@ int z_putc(int c)
|
||||
else err(f__svic->icierr,110,"recend");
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
z_rnew(Void)
|
||||
{
|
||||
f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen;
|
||||
@ -47,9 +43,9 @@ z_endp(Void)
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
int c_si(a) icilist *a;
|
||||
c_si(a) icilist *a;
|
||||
#else
|
||||
int c_si(icilist *a)
|
||||
c_si(icilist *a)
|
||||
#endif
|
||||
{
|
||||
f__elist = (cilist *)a;
|
||||
@ -86,7 +82,7 @@ integer s_rsfi(a) icilist *a;
|
||||
integer s_rsfi(icilist *a)
|
||||
#endif
|
||||
{ int n;
|
||||
if( (n=c_si(a)) ) return(n);
|
||||
if(n=c_si(a)) return(n);
|
||||
f__reading=1;
|
||||
f__doed=rd_ed;
|
||||
f__doned=rd_ned;
|
||||
@ -97,7 +93,6 @@ integer s_rsfi(icilist *a)
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
z_wnew(Void)
|
||||
{
|
||||
if (f__recpos < f__hiwater) {
|
||||
@ -118,7 +113,7 @@ integer s_wsfi(a) icilist *a;
|
||||
integer s_wsfi(icilist *a)
|
||||
#endif
|
||||
{ int n;
|
||||
if( (n=c_si(a)) ) return(n);
|
||||
if(n=c_si(a)) return(n);
|
||||
f__reading=0;
|
||||
f__doed=w_ed;
|
||||
f__doned=w_ned;
|
||||
|
@ -1,4 +1,3 @@
|
||||
#include <unistd.h>
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifdef KR_headers
|
||||
@ -54,7 +53,7 @@ integer f_inqu(inlist *a)
|
||||
}
|
||||
}
|
||||
if(a->inex!=NULL)
|
||||
if((byfile && x != -1) || (!byfile && p!=NULL))
|
||||
if(byfile && x != -1 || !byfile && p!=NULL)
|
||||
*a->inex=1;
|
||||
else *a->inex=0;
|
||||
if(a->inopen!=NULL)
|
||||
@ -62,7 +61,7 @@ integer f_inqu(inlist *a)
|
||||
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))
|
||||
if(byfile || p!=NULL && p->ufnm!=NULL)
|
||||
*a->innamed=1;
|
||||
else *a->innamed=0;
|
||||
if(a->inname!=NULL)
|
||||
|
@ -1,41 +0,0 @@
|
||||
Notice fd29c05f 1184
|
||||
README ef678ce5 8578
|
||||
Version.c 367e2b0 11141
|
||||
backspace.c e29c7ec1 1794
|
||||
close.c 175acd02 1336
|
||||
dfe.c 16facc04 2891
|
||||
dolio.c 17595b24 404
|
||||
due.c f05f7fa6 1519
|
||||
endfile.c 12d875dc 3400
|
||||
err.c fccb27de 6084
|
||||
f2ch.add fed3bb7b 6056
|
||||
fio.h e7e8a21c 2315
|
||||
fmt.c e37e7c2a 7857
|
||||
fmt.h 7686340 1835
|
||||
fmtlib.c f79c9df4 704
|
||||
fp.h 100fb355 665
|
||||
iio.c fedbf0b5 2374
|
||||
ilnw.c fa459169 1049
|
||||
inquire.c e1059667 2536
|
||||
lio.h a087b39 1564
|
||||
lread.c 4dfc73b 12130
|
||||
lwrite.c 19137b45 4565
|
||||
makefile e8266f12 1972
|
||||
open.c 1ef408ec 4512
|
||||
rawio.h b9d538d 688
|
||||
rdfmt.c 55975ac 8347
|
||||
rewind.c 87b080b 408
|
||||
rsfe.c 1d79e4a1 1415
|
||||
rsli.c 1259dfec 1748
|
||||
rsne.c f2e2cad1 11466
|
||||
sfe.c 45a6968 793
|
||||
sue.c ec169681 1803
|
||||
typesize.c e5660590 319
|
||||
uio.c fe44d524 1547
|
||||
util.c f17978be 824
|
||||
wref.c fbed7e10 4507
|
||||
wrtfmt.c 7a73318 8090
|
||||
wsfe.c 250d1ef 1658
|
||||
wsle.c f74ea563 684
|
||||
wsne.c ea4dac25 412
|
||||
xwsne.c 16641f3c 1135
|
@ -67,7 +67,6 @@ 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);
|
||||
@ -80,7 +79,12 @@ integer e_rsle(Void)
|
||||
{
|
||||
int ch;
|
||||
if(f__curunit->uend) return(0);
|
||||
while((ch=t_getc())!='\n' && ch!=EOF);
|
||||
while((ch=t_getc())!='\n')
|
||||
if (ch == EOF) {
|
||||
if(feof(f__cf))
|
||||
f__curunit->uend = l_eof = 1;
|
||||
return EOF;
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
|
||||
@ -88,14 +92,14 @@ 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 ERR(x) if(n=(x)) return(n)
|
||||
#define GETC(x) (x=(*l_getc)())
|
||||
#define Ungetc(x,y) (*l_ungetc)(x,y)
|
||||
|
||||
#ifdef KR_headers
|
||||
int l_R(poststar) int poststar;
|
||||
l_R(poststar) int poststar;
|
||||
#else
|
||||
int l_R(int poststar)
|
||||
l_R(int poststar)
|
||||
#endif
|
||||
{
|
||||
char s[FMAX+EXPMAXDIGS+4];
|
||||
@ -250,7 +254,6 @@ rd_count(register int ch)
|
||||
return f__lcount <= 0;
|
||||
}
|
||||
|
||||
int
|
||||
l_C(Void)
|
||||
{ int ch, nml_save;
|
||||
double lz;
|
||||
@ -287,7 +290,7 @@ l_C(Void)
|
||||
Ungetc(ch,f__cf);
|
||||
nml_save = nml_read;
|
||||
nml_read = 0;
|
||||
if ( (ch = l_R(1)) )
|
||||
if (ch = l_R(1))
|
||||
return ch;
|
||||
if (!f__ltype)
|
||||
errfl(f__elist->cierr,112,"no real part");
|
||||
@ -299,7 +302,7 @@ l_C(Void)
|
||||
}
|
||||
while(iswhit(GETC(ch)));
|
||||
(void) Ungetc(ch,f__cf);
|
||||
if ( (ch = l_R(1)) )
|
||||
if (ch = l_R(1))
|
||||
return ch;
|
||||
if (!f__ltype)
|
||||
errfl(f__elist->cierr,112,"no imaginary part");
|
||||
@ -313,8 +316,6 @@ l_C(Void)
|
||||
nml_read = nml_save;
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
l_L(Void)
|
||||
{
|
||||
int ch;
|
||||
@ -361,8 +362,6 @@ l_L(Void)
|
||||
return(0);
|
||||
}
|
||||
#define BUFSIZE 128
|
||||
|
||||
int
|
||||
l_CHAR(Void)
|
||||
{ int ch,size,i;
|
||||
static char rafail[] = "realloc failure";
|
||||
@ -485,9 +484,9 @@ l_CHAR(Void)
|
||||
}
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int c_le(a) cilist *a;
|
||||
c_le(a) cilist *a;
|
||||
#else
|
||||
int c_le(cilist *a)
|
||||
c_le(cilist *a)
|
||||
#endif
|
||||
{
|
||||
if(!f__init)
|
||||
@ -505,9 +504,9 @@ int c_le(cilist *a)
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
|
||||
l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
|
||||
#else
|
||||
int l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
#endif
|
||||
{
|
||||
#define Ptr ((flex *)ptr)
|
||||
@ -525,7 +524,7 @@ int l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
GETC(ch);
|
||||
switch(ch) {
|
||||
case EOF:
|
||||
goto loopend;
|
||||
err(f__elist->ciend,(EOF),"list in")
|
||||
case ' ':
|
||||
case '\t':
|
||||
case '\n':
|
||||
@ -579,13 +578,9 @@ int l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
Ungetc(ch,f__cf);
|
||||
loopend:
|
||||
if(f__lquit) return(0);
|
||||
if(f__cf) {
|
||||
if (feof(f__cf))
|
||||
err(f__elist->ciend,(EOF),"list in")
|
||||
else if(ferror(f__cf)) {
|
||||
clearerr(f__cf);
|
||||
errfl(f__elist->cierr,errno,"list in");
|
||||
}
|
||||
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)
|
||||
@ -645,7 +640,7 @@ integer s_rsle(cilist *a)
|
||||
{
|
||||
int n;
|
||||
|
||||
if( (n=c_le(a)) ) return(n);
|
||||
if(n=c_le(a)) return(n);
|
||||
f__reading=1;
|
||||
f__external=1;
|
||||
f__formatted=1;
|
||||
|
@ -14,9 +14,9 @@ donewrec(Void)
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
int t_putc(c)
|
||||
t_putc(c)
|
||||
#else
|
||||
int t_putc(int c)
|
||||
t_putc(int c)
|
||||
#endif
|
||||
{
|
||||
f__recpos++;
|
||||
@ -141,7 +141,7 @@ l_g(char *buf, double n)
|
||||
switch(*b) {
|
||||
#ifndef WANT_LEAD_0
|
||||
case '0':
|
||||
while( (b[0] = b[1]) )
|
||||
while(b[0] = b[1])
|
||||
b++;
|
||||
break;
|
||||
#endif
|
||||
@ -166,7 +166,7 @@ l_g(char *buf, double n)
|
||||
while(*++b);
|
||||
goto f__ret;
|
||||
case 'E':
|
||||
for(c1 = '.', c = 'E'; (*b = c1);
|
||||
for(c1 = '.', c = 'E'; *b = c1;
|
||||
c1 = c, c = *++b);
|
||||
goto f__ret;
|
||||
}
|
||||
@ -188,7 +188,7 @@ l_put(register char *s)
|
||||
#else
|
||||
register int c, (*pn)(int) = f__putn;
|
||||
#endif
|
||||
while( (c = *s++) )
|
||||
while(c = *s++)
|
||||
(*pn)(c);
|
||||
}
|
||||
|
||||
@ -240,9 +240,9 @@ lwrt_C(double a, double b)
|
||||
PUT(')');
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
|
||||
l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
|
||||
#else
|
||||
int l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
|
||||
#endif
|
||||
{
|
||||
#define Ptr ((flex *)ptr)
|
||||
|
@ -1,96 +0,0 @@
|
||||
.SUFFIXES: .c .o
|
||||
CC = cc
|
||||
CFLAGS = -O
|
||||
SHELL = /bin/sh
|
||||
|
||||
# compile, then strip unnecessary symbols
|
||||
.c.o:
|
||||
$(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c
|
||||
ld -r -x -o $*.xxx $*.o
|
||||
mv $*.xxx $*.o
|
||||
|
||||
OBJ = Version.o backspace.o close.o dfe.o dolio.o due.o endfile.o err.o \
|
||||
fmt.o fmtlib.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
|
||||
libI77.a: $(OBJ)
|
||||
ar r libI77.a $?
|
||||
ranlib libI77.a
|
||||
install: libI77.a
|
||||
cp libI77.a /usr/lib/libI77.a
|
||||
ranlib /usr/lib/libI77.a
|
||||
|
||||
Version.o: Version.c
|
||||
$(CC) -c Version.c
|
||||
|
||||
# To compile with C++, first "make f2c.h"
|
||||
f2c.h: f2ch.add
|
||||
cat /usr/include/f2c.h f2ch.add >f2c.h
|
||||
|
||||
|
||||
clean:
|
||||
rm -f $(OBJ) libI77.a
|
||||
|
||||
clobber: clean
|
||||
rm -f libI77.a
|
||||
|
||||
backspace.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
|
||||
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
|
||||
|
||||
check:
|
||||
xsum Notice README Version.c backspace.c close.c dfe.c dolio.c \
|
||||
due.c endfile.c err.c f2ch.add fio.h fmt.c fmt.h fmtlib.c fp.h \
|
||||
iio.c ilnw.c inquire.c lio.h lread.c lwrite.c makefile open.c \
|
||||
rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c sue.c \
|
||||
typesize.c uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c \
|
||||
xwsne.c >zap
|
||||
cmp zap libI77.xsum && rm zap || diff libI77.xsum zap
|
@ -1,4 +1,3 @@
|
||||
#include <unistd.h>
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#include "sys/types.h"
|
||||
#include "sys/stat.h"
|
||||
@ -29,9 +28,9 @@ char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
int f__isdev(s) char *s;
|
||||
f__isdev(s) char *s;
|
||||
#else
|
||||
int f__isdev(char *s)
|
||||
f__isdev(char *s)
|
||||
#endif
|
||||
{
|
||||
#ifdef NON_UNIX_STDIO
|
||||
@ -165,7 +164,7 @@ integer f_open(olist *a)
|
||||
case 'R':
|
||||
replace:
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if ( (tf = fopen(buf,f__w_mode[0])) )
|
||||
if (tf = fopen(buf,f__w_mode[0]))
|
||||
fclose(tf);
|
||||
#else
|
||||
(void) close(creat(buf, 0666));
|
||||
@ -188,9 +187,9 @@ integer f_open(olist *a)
|
||||
else {
|
||||
if(!(b->ufd = fopen(buf, f__r_mode[ufmt]))) {
|
||||
#ifdef NON_UNIX_STDIO
|
||||
if ( (b->ufd = fopen(buf, f__w_mode[ufmt|2])) )
|
||||
if (b->ufd = fopen(buf, f__w_mode[ufmt|2]))
|
||||
b->uwrt = 2;
|
||||
else if ( (b->ufd = fopen(buf, f__w_mode[ufmt])) )
|
||||
else if (b->ufd = fopen(buf, f__w_mode[ufmt]))
|
||||
b->uwrt = 1;
|
||||
else
|
||||
#else
|
||||
@ -220,9 +219,9 @@ integer f_open(olist *a)
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int fk_open(seq,fmt,n) ftnint n;
|
||||
fk_open(seq,fmt,n) ftnint n;
|
||||
#else
|
||||
int fk_open(int seq, int fmt, ftnint n)
|
||||
fk_open(int seq, int fmt, ftnint n)
|
||||
#endif
|
||||
{ char nbuf[10];
|
||||
olist a;
|
||||
|
@ -1,38 +1,32 @@
|
||||
#ifdef KR_headers
|
||||
#ifndef __FreeBSD__
|
||||
extern FILE *fdopen();
|
||||
#endif
|
||||
#else
|
||||
#ifdef MSDOS
|
||||
#include "io.h"
|
||||
#ifndef WATCOM
|
||||
#define close _close
|
||||
#define creat _creat
|
||||
#define open _open
|
||||
#define read _read
|
||||
#define write _write
|
||||
#endif
|
||||
#endif /*WATCOM*/
|
||||
#endif /*MSDOS*/
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
#ifndef MSDOS
|
||||
#ifdef OPEN_DECL
|
||||
#ifndef __FreeBSD__
|
||||
extern int creat(const char*,int), open(const char*,int);
|
||||
#endif
|
||||
#endif
|
||||
#ifndef __FreeBSD__
|
||||
extern int close(int);
|
||||
extern int read(int,void*,size_t), write(int,void*,size_t);
|
||||
extern int unlink(const char*);
|
||||
#endif
|
||||
#ifndef _POSIX_SOURCE
|
||||
#ifndef NON_UNIX_STDIO
|
||||
#ifndef __FreeBSD__
|
||||
extern FILE *fdopen(int, const char*);
|
||||
#endif
|
||||
#endif
|
||||
#endif
|
||||
#endif
|
||||
#endif /*KR_HEADERS*/
|
||||
|
||||
extern char *mktemp(char*);
|
||||
|
||||
|
@ -2,6 +2,7 @@
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#include "fp.h"
|
||||
#include "ctype.h"
|
||||
|
||||
extern int f__cursor;
|
||||
#ifdef KR_headers
|
||||
@ -29,10 +30,10 @@ rd_Z(Uint *n, int w, ftnlen len)
|
||||
|
||||
if (!hex['0']) {
|
||||
s = "0123456789";
|
||||
while( (ch = *s++) )
|
||||
while(ch = *s++)
|
||||
hex[ch] = ch - '0' + 1;
|
||||
s = "ABCDEF";
|
||||
while( (ch = *s++) )
|
||||
while(ch = *s++)
|
||||
hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
|
||||
}
|
||||
s = s0 = (char *)x;
|
||||
@ -61,7 +62,7 @@ rd_Z(Uint *n, int w, ftnlen len)
|
||||
return errno = 115;
|
||||
w = (int)len;
|
||||
w1 = s - s0;
|
||||
w2 = (w1+1) >> 1;
|
||||
w2 = w1+1 >> 1;
|
||||
t = (char *)n;
|
||||
if (*(char *)&one) {
|
||||
/* little endian */
|
||||
@ -83,7 +84,7 @@ rd_Z(Uint *n, int w, ftnlen len)
|
||||
t += i;
|
||||
}
|
||||
do {
|
||||
*t = ((hex[*s0 & 0xff]-1) << 4) | (hex[s0[1] & 0xff]-1);
|
||||
*t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
|
||||
t += i;
|
||||
s0 += 2;
|
||||
}
|
||||
@ -154,8 +155,6 @@ rd_L(ftnint *n, int w, ftnlen len)
|
||||
return 0;
|
||||
}
|
||||
|
||||
#include "ctype.h"
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
rd_F(p, w, d, len) ufloat *p; ftnlen len;
|
||||
@ -387,9 +386,9 @@ rd_POS(char *s)
|
||||
return(1);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
|
||||
rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
|
||||
#else
|
||||
int rd_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
rd_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{ int ch;
|
||||
for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
|
||||
@ -450,9 +449,9 @@ int rd_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
return(errno);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int rd_ned(p) struct syl *p;
|
||||
rd_ned(p) struct syl *p;
|
||||
#else
|
||||
int rd_ned(struct syl *p)
|
||||
rd_ned(struct syl *p)
|
||||
#endif
|
||||
{
|
||||
switch(p->op)
|
||||
|
@ -3,7 +3,6 @@
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
|
||||
int
|
||||
xrd_SL(Void)
|
||||
{ int ch;
|
||||
if(!f__curunit->uend)
|
||||
@ -15,8 +14,6 @@ xrd_SL(Void)
|
||||
f__cursor=f__recpos=0;
|
||||
return(1);
|
||||
}
|
||||
|
||||
int
|
||||
x_getc(Void)
|
||||
{ int ch;
|
||||
if(f__curunit->uend) return(EOF);
|
||||
@ -36,15 +33,11 @@ x_getc(Void)
|
||||
}
|
||||
return(-1);
|
||||
}
|
||||
|
||||
int
|
||||
x_endp(Void)
|
||||
{
|
||||
(void) xrd_SL();
|
||||
return(0);
|
||||
xrd_SL();
|
||||
return f__curunit->uend == 1 ? EOF : 0;
|
||||
}
|
||||
|
||||
int
|
||||
x_rev(Void)
|
||||
{
|
||||
(void) xrd_SL();
|
||||
@ -57,7 +50,7 @@ integer s_rsfe(cilist *a) /* start */
|
||||
#endif
|
||||
{ int n;
|
||||
if(!f__init) f_init();
|
||||
if( (n=c_sfe(a)) ) return(n);
|
||||
if(n=c_sfe(a)) return(n);
|
||||
f__reading=1;
|
||||
f__sequential=1;
|
||||
f__formatted=1;
|
||||
|
@ -18,7 +18,8 @@ static int i_getc(Void)
|
||||
z_rnew();
|
||||
}
|
||||
f__recpos++;
|
||||
if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"internal read");
|
||||
if(f__icptr >= f__icend)
|
||||
return EOF;
|
||||
return(*f__icptr++);
|
||||
}
|
||||
|
||||
|
@ -29,7 +29,7 @@
|
||||
typedef struct hashtab hashtab;
|
||||
|
||||
static hashtab *nl_cache;
|
||||
static n_nlcache;
|
||||
static int n_nlcache;
|
||||
static hashentry **zot;
|
||||
static int colonseen;
|
||||
extern ftnlen f__typesize[];
|
||||
@ -78,7 +78,7 @@ hash(hashtab *ht, register char *s)
|
||||
register hashentry *h;
|
||||
char *s0 = s;
|
||||
|
||||
for(x = 0; (c = *s++); x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
|
||||
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))
|
||||
@ -99,7 +99,7 @@ mk_hashtab(Namelist *nl)
|
||||
hashentry *he;
|
||||
|
||||
hashtab **x, **x0, *y;
|
||||
for(x = &nl_cache; (y = *x); x0 = x, x = &y->next)
|
||||
for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
|
||||
if (nl == y->nl)
|
||||
return y;
|
||||
if (n_nlcache >= MAX_NL_CACHE) {
|
||||
@ -151,13 +151,13 @@ nl_init(Void) {
|
||||
|
||||
if(!f__init)
|
||||
f_init();
|
||||
for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; (c = *s++); )
|
||||
for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
|
||||
Alpha[c]
|
||||
= Alphanum[c]
|
||||
= Alpha[c + 'a' - 'A']
|
||||
= Alphanum[c + 'a' - 'A']
|
||||
= c;
|
||||
for(s = "0123456789_"; (c = *s++); )
|
||||
for(s = "0123456789_"; c = *s++; )
|
||||
Alphanum[c] = c;
|
||||
}
|
||||
|
||||
@ -180,7 +180,7 @@ getname(register char *s, int slen)
|
||||
ch = 115;
|
||||
errfl(f__elist->cierr, ch, "namelist read");
|
||||
}
|
||||
while( (*s = Alphanum[GETC(ch) & 0xff]) )
|
||||
while(*s = Alphanum[GETC(ch) & 0xff])
|
||||
if (s < se)
|
||||
s++;
|
||||
if (ch == EOF)
|
||||
@ -235,15 +235,15 @@ getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
|
||||
register int k;
|
||||
ftnlen x2, x3;
|
||||
|
||||
if ( (k = getnum(chp, x1)) )
|
||||
if (k = getnum(chp, x1))
|
||||
return k;
|
||||
x3 = 1;
|
||||
if (*chp == ':') {
|
||||
if ( (k = getnum(chp, &x2)) )
|
||||
if (k = getnum(chp, &x2))
|
||||
return k;
|
||||
x2 -= *x1;
|
||||
if (*chp == ':') {
|
||||
if ( (k = getnum(chp, &x3)) )
|
||||
if (k = getnum(chp, &x3))
|
||||
return k;
|
||||
if (!x3)
|
||||
return 123;
|
||||
@ -291,9 +291,9 @@ print_ne(cilist *a)
|
||||
static char where0[] = "namelist read start ";
|
||||
|
||||
#ifdef KR_headers
|
||||
int x_rsne(a) cilist *a;
|
||||
x_rsne(a) cilist *a;
|
||||
#else
|
||||
int x_rsne(cilist *a)
|
||||
x_rsne(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int ch, got1, k, n, nd, quote, readall;
|
||||
@ -340,7 +340,7 @@ int x_rsne(cilist *a)
|
||||
#endif
|
||||
}
|
||||
have_amp:
|
||||
if ( (ch = getname(buf,sizeof(buf))) )
|
||||
if (ch = getname(buf,sizeof(buf)))
|
||||
return ch;
|
||||
nl = (Namelist *)a->cifmt;
|
||||
if (strcmp(buf, nl->name))
|
||||
@ -392,10 +392,10 @@ int x_rsne(cilist *a)
|
||||
case '&':
|
||||
return 0;
|
||||
default:
|
||||
if ((ch <= ' ' && ch >= 0) || (ch == ','))
|
||||
if (ch <= ' ' && ch >= 0 || ch == ',')
|
||||
continue;
|
||||
Ungetc(ch,f__cf);
|
||||
if ( (ch = getname(buf,sizeof(buf))) )
|
||||
if (ch = getname(buf,sizeof(buf)))
|
||||
return ch;
|
||||
goto havename;
|
||||
}
|
||||
@ -419,8 +419,8 @@ int x_rsne(cilist *a)
|
||||
if (!(dims = v->dims)) {
|
||||
if (type != TYCHAR)
|
||||
errfl(a->cierr, 122, where);
|
||||
if ( (k = getdimen(&ch, dn, (ftnlen)size,
|
||||
(ftnlen)size, &b)) )
|
||||
if (k = getdimen(&ch, dn, (ftnlen)size,
|
||||
(ftnlen)size, &b))
|
||||
errfl(a->cierr, k, where);
|
||||
if (ch != ')')
|
||||
errfl(a->cierr, 115, where);
|
||||
@ -436,7 +436,7 @@ int x_rsne(cilist *a)
|
||||
nomax = span = dims[1];
|
||||
ivae = iva + size*nomax;
|
||||
colonseen = 0;
|
||||
if ( (k = getdimen(&ch, dn, size, nomax, &b)) )
|
||||
if (k = getdimen(&ch, dn, size, nomax, &b))
|
||||
errfl(a->cierr, k, where);
|
||||
no = dn->extent;
|
||||
b0 = dims[2];
|
||||
@ -447,8 +447,8 @@ int x_rsne(cilist *a)
|
||||
errfl(a->cierr, 115, where);
|
||||
dn1 = dn + 1;
|
||||
span /= *dims;
|
||||
if ( (k = getdimen(&ch, dn1, dn->delta**dims,
|
||||
span, &b1)) )
|
||||
if (k = getdimen(&ch, dn1, dn->delta**dims,
|
||||
span, &b1))
|
||||
errfl(a->cierr, k, where);
|
||||
ex *= *dims;
|
||||
b += b1*ex;
|
||||
@ -467,7 +467,7 @@ int x_rsne(cilist *a)
|
||||
no1 = 1;
|
||||
dn0 = dimens;
|
||||
if (type == TYCHAR && ch == '(' /*)*/) {
|
||||
if ( (k = getdimen(&ch, &substr, size, size, &b)) )
|
||||
if (k = getdimen(&ch, &substr, size, size, &b))
|
||||
errfl(a->cierr, k, where);
|
||||
if (ch != ')')
|
||||
errfl(a->cierr, 115, where);
|
||||
@ -502,7 +502,7 @@ int x_rsne(cilist *a)
|
||||
dn1->delta -= ex;
|
||||
}
|
||||
}
|
||||
else if ( (dims = v->dims) ) {
|
||||
else if (dims = v->dims) {
|
||||
no = no1 = dims[1];
|
||||
ivae = iva + no*size;
|
||||
}
|
||||
@ -522,7 +522,7 @@ int x_rsne(cilist *a)
|
||||
else if (iva + no1*size > ivae)
|
||||
no1 = (ivae - iva)/size;
|
||||
f__lquit = 0;
|
||||
if ( (k = l_read(&no1, vaddr + iva, size, type)) )
|
||||
if (k = l_read(&no1, vaddr + iva, size, type))
|
||||
return k;
|
||||
if (f__lquit == 1)
|
||||
return 0;
|
||||
@ -533,8 +533,8 @@ int x_rsne(cilist *a)
|
||||
if (no1 > f__lcount)
|
||||
no1 = f__lcount;
|
||||
iva += no1 * dn0->delta;
|
||||
if ( (k = l_read(&no1, vaddr + iva,
|
||||
size, type)) )
|
||||
if (k = l_read(&no1, vaddr + iva,
|
||||
size, type))
|
||||
return k;
|
||||
}
|
||||
}
|
||||
@ -594,7 +594,7 @@ s_rsne(cilist *a)
|
||||
|
||||
f__external=1;
|
||||
l_eof = 0;
|
||||
if( (n = c_le(a)) )
|
||||
if(n = c_le(a))
|
||||
return n;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr,errno,where0);
|
||||
|
@ -15,9 +15,9 @@ integer e_rsfe(Void)
|
||||
return(n);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int c_sfe(a) cilist *a; /* check */
|
||||
c_sfe(a) cilist *a; /* check */
|
||||
#else
|
||||
int c_sfe(cilist *a) /* check */
|
||||
c_sfe(cilist *a) /* check */
|
||||
#endif
|
||||
{ unit *p;
|
||||
if(a->ciunit >= MXUNIT || a->ciunit<0)
|
||||
|
@ -4,9 +4,9 @@ extern uiolen f__reclen;
|
||||
long f__recloc;
|
||||
|
||||
#ifdef KR_headers
|
||||
int c_sue(a) cilist *a;
|
||||
c_sue(a) cilist *a;
|
||||
#else
|
||||
int c_sue(cilist *a)
|
||||
c_sue(cilist *a)
|
||||
#endif
|
||||
{
|
||||
if(a->ciunit >= MXUNIT || a->ciunit < 0)
|
||||
@ -31,7 +31,7 @@ integer s_rsue(cilist *a)
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
f__reading=1;
|
||||
if( (n=c_sue(a)) ) return(n);
|
||||
if(n=c_sue(a)) return(n);
|
||||
f__recpos=0;
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr, errno, "read start");
|
||||
@ -54,7 +54,7 @@ integer s_wsue(cilist *a)
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
if( (n=c_sue(a)) ) return(n);
|
||||
if(n=c_sue(a)) return(n);
|
||||
f__reading=0;
|
||||
f__reclen=0;
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
|
@ -3,9 +3,9 @@
|
||||
uiolen f__reclen;
|
||||
|
||||
#ifdef KR_headers
|
||||
int do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
|
||||
do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
|
||||
#else
|
||||
int do_us(ftnint *number, char *ptr, ftnlen len)
|
||||
do_us(ftnint *number, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
if(f__reading)
|
||||
@ -23,7 +23,6 @@ int do_us(ftnint *number, char *ptr, ftnlen len)
|
||||
(void) fwrite(ptr,(int)len,(int)(*number),f__cf);
|
||||
return(0);
|
||||
}
|
||||
return (0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
|
||||
|
@ -15,9 +15,9 @@
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
int wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
|
||||
wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
|
||||
#else
|
||||
int wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
char buf[FMAX+EXPMAXDIGS+4], *s, *se;
|
||||
@ -118,7 +118,7 @@ int wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
if (s[2]) {
|
||||
#ifdef Pedantic
|
||||
if (!e0 && !s[3])
|
||||
e1 = 2; /* for(s -= 2, e1 = 2; s[0] = s[1]; s++); */
|
||||
e1 = 2;/* 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 */
|
||||
@ -127,7 +127,7 @@ int wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
/* exponent field if it fits. */
|
||||
#else
|
||||
if (!e0) {
|
||||
for(s -= 2, e1 = 2; (s[0] = s[1]); s++)
|
||||
for(s -= 2, e1 = 2; s[0] = s[1]; s++)
|
||||
#ifdef CRAY
|
||||
delta--;
|
||||
if ((delta += 4) < 0)
|
||||
@ -191,9 +191,9 @@ int wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
}
|
||||
|
||||
#ifdef KR_headers
|
||||
int wrt_F(p,w,d,len) ufloat *p; ftnlen len;
|
||||
wrt_F(p,w,d,len) ufloat *p; ftnlen len;
|
||||
#else
|
||||
int wrt_F(ufloat *p, int w, int d, ftnlen len)
|
||||
wrt_F(ufloat *p, int w, int d, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
int d1, sign, n;
|
||||
@ -217,7 +217,7 @@ int wrt_F(ufloat *p, int w, int d, ftnlen len)
|
||||
#endif
|
||||
}
|
||||
|
||||
if ( (n = f__scale) )
|
||||
if (n = f__scale)
|
||||
if (n > 0)
|
||||
do x *= 10.; while(--n > 0);
|
||||
else
|
||||
@ -267,7 +267,7 @@ int wrt_F(ufloat *p, int w, int d, ftnlen len)
|
||||
PUT('-');
|
||||
else if (f__cplus)
|
||||
PUT('+');
|
||||
while( (n = *b++) )
|
||||
while(n = *b++)
|
||||
PUT(n);
|
||||
while(--d1 >= 0)
|
||||
PUT('0');
|
||||
|
@ -2,87 +2,84 @@
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
|
||||
extern int f__cursor;
|
||||
int f__hiwater;
|
||||
icilist *f__svic;
|
||||
char *f__icptr;
|
||||
extern icilist *f__svic;
|
||||
extern char *f__icptr;
|
||||
|
||||
int
|
||||
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(f__cursor < 0) {
|
||||
if(cursor < 0) {
|
||||
if(f__hiwater < f__recpos)
|
||||
f__hiwater = f__recpos;
|
||||
f__recpos += f__cursor;
|
||||
f__icptr += f__cursor;
|
||||
f__cursor = 0;
|
||||
f__recpos += cursor;
|
||||
f__icptr += cursor;
|
||||
if(f__recpos < 0)
|
||||
err(f__elist->cierr, 110, "left off");
|
||||
}
|
||||
else if(f__cursor > 0) {
|
||||
if(f__recpos + f__cursor >= f__svic->icirlen)
|
||||
else if(cursor > 0) {
|
||||
if(f__recpos + cursor >= f__svic->icirlen)
|
||||
err(f__elist->cierr, 110, "recend");
|
||||
if(f__hiwater <= f__recpos)
|
||||
for(; f__cursor > 0; f__cursor--)
|
||||
for(; cursor > 0; cursor--)
|
||||
(*f__putn)(' ');
|
||||
else if(f__hiwater <= f__recpos + f__cursor) {
|
||||
f__cursor -= f__hiwater - f__recpos;
|
||||
else if(f__hiwater <= f__recpos + cursor) {
|
||||
cursor -= f__hiwater - f__recpos;
|
||||
f__icptr += f__hiwater - f__recpos;
|
||||
f__recpos = f__hiwater;
|
||||
for(; f__cursor > 0; f__cursor--)
|
||||
for(; cursor > 0; cursor--)
|
||||
(*f__putn)(' ');
|
||||
}
|
||||
else {
|
||||
f__icptr += f__cursor;
|
||||
f__recpos += f__cursor;
|
||||
f__icptr += cursor;
|
||||
f__recpos += cursor;
|
||||
}
|
||||
f__cursor = 0;
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
if(f__cursor > 0) {
|
||||
if(cursor > 0) {
|
||||
if(f__hiwater <= f__recpos)
|
||||
for(;f__cursor>0;f__cursor--) (*f__putn)(' ');
|
||||
else if(f__hiwater <= f__recpos + f__cursor) {
|
||||
for(;cursor>0;cursor--) (*f__putn)(' ');
|
||||
else if(f__hiwater <= f__recpos + cursor) {
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
|
||||
f__cf->_ptr += f__hiwater - f__recpos;
|
||||
else
|
||||
#endif
|
||||
(void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR);
|
||||
f__cursor -= f__hiwater - f__recpos;
|
||||
cursor -= f__hiwater - f__recpos;
|
||||
f__recpos = f__hiwater;
|
||||
for(; f__cursor > 0; f__cursor--)
|
||||
for(; cursor > 0; cursor--)
|
||||
(*f__putn)(' ');
|
||||
}
|
||||
else {
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if(f__cf->_ptr + f__cursor < buf_end(f__cf))
|
||||
f__cf->_ptr += f__cursor;
|
||||
if(f__cf->_ptr + cursor < buf_end(f__cf))
|
||||
f__cf->_ptr += cursor;
|
||||
else
|
||||
#endif
|
||||
(void) fseek(f__cf, (long)f__cursor, SEEK_CUR);
|
||||
f__recpos += f__cursor;
|
||||
(void) fseek(f__cf, (long)cursor, SEEK_CUR);
|
||||
f__recpos += cursor;
|
||||
}
|
||||
}
|
||||
if(f__cursor<0)
|
||||
if(cursor<0)
|
||||
{
|
||||
if(f__cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
|
||||
if(cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
|
||||
#ifndef NON_UNIX_STDIO
|
||||
if(f__cf->_ptr + f__cursor >= f__cf->_base)
|
||||
f__cf->_ptr += f__cursor;
|
||||
if(f__cf->_ptr + cursor >= f__cf->_base)
|
||||
f__cf->_ptr += cursor;
|
||||
else
|
||||
#endif
|
||||
if(f__curunit && f__curunit->useek)
|
||||
(void) fseek(f__cf,(long)f__cursor,SEEK_CUR);
|
||||
(void) fseek(f__cf,(long)cursor,SEEK_CUR);
|
||||
else
|
||||
err(f__elist->cierr,106,"fmt");
|
||||
if(f__hiwater < f__recpos)
|
||||
f__hiwater = f__recpos;
|
||||
f__recpos += f__cursor;
|
||||
f__cursor=0;
|
||||
f__recpos += cursor;
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
@ -95,7 +92,7 @@ wrt_Z(Uint *n, int w, int minlen, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
register char *s, *se;
|
||||
register i, w1;
|
||||
register int i, w1;
|
||||
static int one = 1;
|
||||
static char hex[] = "0123456789ABCDEF";
|
||||
s = (char *)n;
|
||||
@ -214,7 +211,10 @@ wrt_AP(s) char *s;
|
||||
wrt_AP(char *s)
|
||||
#endif
|
||||
{ char quote;
|
||||
if(f__cursor && mv_cur()) return(mv_cur());
|
||||
int i;
|
||||
|
||||
if(f__cursor && (i = mv_cur()))
|
||||
return i;
|
||||
quote = *s++;
|
||||
for(;*s;s++)
|
||||
{ if(*s!=quote) (*f__putn)(*s);
|
||||
@ -230,14 +230,17 @@ wrt_H(a,s) char *s;
|
||||
wrt_H(int a, char *s)
|
||||
#endif
|
||||
{
|
||||
if(f__cursor && mv_cur()) return(mv_cur());
|
||||
int i;
|
||||
|
||||
if(f__cursor && (i = mv_cur()))
|
||||
return i;
|
||||
while(a--) (*f__putn)(*s++);
|
||||
return(1);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int wrt_L(n,len, sz) Uint *n; ftnlen sz;
|
||||
wrt_L(n,len, sz) Uint *n; ftnlen sz;
|
||||
#else
|
||||
int wrt_L(Uint *n, int len, ftnlen sz)
|
||||
wrt_L(Uint *n, int len, ftnlen sz)
|
||||
#endif
|
||||
{ int i;
|
||||
long x;
|
||||
@ -309,12 +312,15 @@ wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
|
||||
return(wrt_E(p,w,d,e,len));
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
|
||||
w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
|
||||
#else
|
||||
int w_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
w_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
if(f__cursor && mv_cur()) return(mv_cur());
|
||||
int i;
|
||||
|
||||
if(f__cursor && (i = mv_cur()))
|
||||
return i;
|
||||
switch(p->op)
|
||||
{
|
||||
default:
|
||||
@ -352,9 +358,9 @@ int w_ed(struct syl *p, char *ptr, ftnlen len)
|
||||
}
|
||||
}
|
||||
#ifdef KR_headers
|
||||
int w_ned(p) struct syl *p;
|
||||
w_ned(p) struct syl *p;
|
||||
#else
|
||||
int w_ned(struct syl *p)
|
||||
w_ned(struct syl *p)
|
||||
#endif
|
||||
{
|
||||
switch(p->op)
|
||||
|
@ -5,9 +5,9 @@
|
||||
extern int f__hiwater;
|
||||
|
||||
#ifdef KR_headers
|
||||
int x_putc(c)
|
||||
x_putc(c)
|
||||
#else
|
||||
int x_putc(int c)
|
||||
x_putc(int c)
|
||||
#endif
|
||||
{
|
||||
/* this uses \n as an indicator of record-end */
|
||||
@ -27,8 +27,6 @@ int x_putc(int c)
|
||||
#endif
|
||||
return putc(c,f__cf);
|
||||
}
|
||||
|
||||
int
|
||||
x_wSL(Void)
|
||||
{
|
||||
(*f__putn)('\n');
|
||||
@ -37,8 +35,6 @@ x_wSL(Void)
|
||||
f__hiwater = 0;
|
||||
return(1);
|
||||
}
|
||||
|
||||
int
|
||||
xw_end(Void)
|
||||
{
|
||||
if(f__nonl == 0)
|
||||
@ -46,8 +42,6 @@ xw_end(Void)
|
||||
f__hiwater = f__recpos = f__cursor = 0;
|
||||
return(0);
|
||||
}
|
||||
|
||||
int
|
||||
xw_rev(Void)
|
||||
{
|
||||
if(f__workdone) (*f__putn)('\n');
|
||||
@ -62,7 +56,7 @@ integer s_wsfe(cilist *a) /*start*/
|
||||
#endif
|
||||
{ int n;
|
||||
if(!f__init) f_init();
|
||||
if( (n=c_sfe(a)) ) return(n);
|
||||
if(n=c_sfe(a)) return(n);
|
||||
f__reading=0;
|
||||
f__sequential=1;
|
||||
f__formatted=1;
|
||||
|
@ -10,7 +10,7 @@ integer s_wsle(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if( (n=c_le(a)) ) return(n);
|
||||
if(n=c_le(a)) return(n);
|
||||
f__reading=0;
|
||||
f__external=1;
|
||||
f__formatted=1;
|
||||
|
@ -11,7 +11,7 @@ s_wsne(cilist *a)
|
||||
{
|
||||
int n;
|
||||
|
||||
if( (n=c_le(a)) )
|
||||
if(n=c_le(a))
|
||||
return(n);
|
||||
f__reading=0;
|
||||
f__external=1;
|
||||
|
@ -5,7 +5,7 @@ CFLAGS+= -DIEEE_drem -DNON_ANSI_RW_MODES -DNON_UNIX_STDIO -DPedantic
|
||||
|
||||
MISC = Version.c main.c s_rnge.c abort_.c getarg_.c iargc_.c getenv_.c\
|
||||
signal_.c s_stop.c s_paus.c system_.c cabs.c\
|
||||
derf_.c derfc_.c erf_.c erfc_.c sig_die.c F77_aloc.c exit.c
|
||||
derf_.c derfc_.c erf_.c erfc_.c sig_die.c F77_aloc.c
|
||||
POW = pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_ri.c pow_zi.c pow_zz.c
|
||||
CX = c_abs.c c_cos.c c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c
|
||||
DCX = z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c
|
||||
@ -23,9 +23,10 @@ HALF = h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c h_mod.c h_nint.c h_sign.c
|
||||
CMP = l_ge.c l_gt.c l_le.c l_lt.c hl_ge.c hl_gt.c hl_le.c hl_lt.c
|
||||
EFL = ef1asc_.c ef1cmc_.c
|
||||
CHAR = s_cat.c s_cmp.c s_copy.c
|
||||
F90BIT = lbitbits.c lbitshft.c
|
||||
|
||||
F77SRCS= $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
|
||||
$(HALF) $(CMP) $(EFL) $(CHAR)
|
||||
$(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT)
|
||||
|
||||
I77SRCS = Version.c backspace.c close.c dfe.c dolio.c due.c endfile.c err.c \
|
||||
fmt.c fmtlib.c iio.c ilnw.c inquire.c lread.c lwrite.c open.c \
|
||||
|
Loading…
Reference in New Issue
Block a user