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

Upgrade to the 1997/02/26 version.

Browse Source
This commit is contained in:
Jean-Marc Zucconi 1997-04-13 01:16:58 +00:00
parent 8609d4594f
commit 4ff323dd45
62 changed files with 575 additions and 783 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/libF77/F77_aloc.c
View File

@ -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);

22
lib/libF77/README
View File

@ -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

10
lib/libF77/Version.c
View File

@ -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.)
*/

2
lib/libF77/abort_.c
View File

@ -12,5 +12,7 @@ int abort_(void)
#endif
{
sig_die("Fortran abort routine called", 1);
#ifdef __cplusplus
return 0;
#endif
}

5
lib/libF77/c_cos.c
View File

@ -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);
}

21
lib/libF77/c_div.c
View File

@ -11,26 +11,27 @@ void c_div(complex *c, complex *a, complex *b)
{
double ratio, den;
double abr, abi;
double ai = a->i, ar = a->r, bi = b->i, br = b->r;
if( (abr = b->r) < 0.)
if( (abr = br) < 0.)
abr = - abr;
if( (abi = b->i) < 0.)
if( (abi = bi) < 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;
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;
ratio = (double)bi / br ;
den = br * (1 + ratio*ratio);
c->r = (ar + ai*ratio) / den;
c->i = (ai - ar*ratio) / den;
}
}

5
lib/libF77/c_log.c
View File

@ -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) );
}

5
lib/libF77/c_sin.c
View File

@ -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);
}

15
lib/libF77/c_sqrt.c
View File

@ -13,22 +13,23 @@ void c_sqrt(complex *r, complex *z)
#endif
{
double mag, t;
double zi = z->i, zr = z->r;
if( (mag = f__cabs(z->r, z->i)) == 0.)
if( (mag = f__cabs(zr, zi)) == 0.)
r->r = r->i = 0.;
else if(z->r > 0)
else if(zr > 0)
{
r->r = t = sqrt(0.5 * (mag + z->r) );
t = z->i / t;
r->r = t = sqrt(0.5 * (mag + zr) );
t = zi / t;
r->i = 0.5 * t;
}
else
{
t = sqrt(0.5 * (mag - z->r) );
if(z->i < 0)
t = sqrt(0.5 * (mag - zr) );
if(zi < 0)
t = -t;
r->i = t;
t = z->i / t;
t = zi / t;
r->r = 0.5 * t;
}
}

4
lib/libF77/ef1asc_.c
View File

@ -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
}

37
lib/libF77/exit.c
View File

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

2
lib/libF77/f2ch.add
View File

@ -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 *);

2
lib/libF77/getenv_.c
View File

@ -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
View 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
View 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);
}

120
lib/libF77/libF77.xsum
View File

@ -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

26
lib/libF77/main.c
View File

@ -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

78
lib/libF77/makefile
View File

@ -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

17
lib/libF77/pow_zi.c
View File

@ -11,15 +11,15 @@ void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */
integer n;
unsigned long u;
double t;
doublecomplex x;
doublecomplex q, x;
static doublecomplex one = {1.0, 0.0};
n = *b;
p->r = 1;
p->i = 0;
q.r = 1;
q.i = 0;
if(n == 0)
return;
goto done;
if(n < 0)
{
n = -n;
@ -35,9 +35,9 @@ for(u = n; ; )
{
if(u & 01)
{
t = p->r * x.r - p->i * x.i;
p->i = p->r * x.i + p->i * x.r;
p->r = t;
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)
{
@ -48,4 +48,7 @@ for(u = n; ; )
else
break;
}
done:
p->i = q.i;
p->r = q.r;
}

4
lib/libF77/s_cat.c
View File

@ -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;

4
lib/libF77/s_paus.c
View File

@ -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

2
lib/libF77/s_rnge.c
View File

@ -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
View 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)

16
lib/libF77/signal_.c
View File

@ -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);
}

5
lib/libF77/z_cos.c
View File

@ -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);
}

22
lib/libF77/z_div.c
View File

@ -10,27 +10,27 @@ void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b)
{
double ratio, den;
double abr, abi;
double ai = a->i, ar = a->r, bi = b->i, br = b->r;
if( (abr = b->r) < 0.)
if( (abr = br) < 0.)
abr = - abr;
if( (abi = b->i) < 0.)
if( (abi = bi) < 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;
ratio = br / bi ;
den = bi * (1 + ratio*ratio);
c->r = (ar*ratio + ai) / den;
c->i = (ai*ratio - ar) / 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;
ratio = bi / br ;
den = br * (1 + ratio*ratio);
c->r = (ar + ai*ratio) / den;
c->i = (ai - ar*ratio) / den;
}
}

6
lib/libF77/z_log.c
View File

@ -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 ) );
}

5
lib/libF77/z_sin.c
View File

@ -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);
}

16
lib/libF77/z_sqrt.c
View File

@ -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.)
if( (mag = f__cabs(zr, zi)) == 0.)
r->r = r->i = 0.;
else if(z->r > 0)
else if(zr > 0)
{
r->r = sqrt(0.5 * (mag + z->r) );
r->i = z->i / r->r / 2;
r->r = sqrt(0.5 * (mag + zr) );
r->i = zi / r->r / 2;
}
else
{
r->i = sqrt(0.5 * (mag - z->r) );
if(z->i < 0)
r->i = sqrt(0.5 * (mag - zr) );
if(zi < 0)
r->i = - r->i;
r->r = z->i / r->i / 2;
r->r = zi / r->i / 2;
}
}

2
lib/libI77/Notice
View File

@ -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

37
lib/libI77/README
View File

@ -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.

24
lib/libI77/Version.c
View File

@ -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. */

23
lib/libI77/dfe.c
View File

@ -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;

11
lib/libI77/due.c
View File

@ -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);

4
lib/libI77/endfile.c
View File

@ -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)) {

19
lib/libI77/err.c
View File

@ -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;

2
lib/libI77/f2ch.add
View File

@ -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 *);

6
lib/libI77/fio.h
View File

@ -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)

22
lib/libI77/fmt.c
View File

@ -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));

3
lib/libI77/fmt.h
View File

@ -45,6 +45,9 @@ typedef union
} ufloat;
typedef union
{ short is;
#ifndef KR_headers
signed
#endif
char ic;
integer il;
#ifdef Allow_TYQUAD

18
lib/libI77/fmtlib.c
View File

@ -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];
}

17
lib/libI77/iio.c
View File

@ -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;

5
lib/libI77/inquire.c
View File

@ -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)

41
lib/libI77/libI77.xsum
View File

@ -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

41
lib/libI77/lread.c
View File

@ -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,14 +578,10 @@ 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)) {
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
lib/libI77/lwrite.c
View File

@ -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)

96
lib/libI77/makefile
View File

@ -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

15
lib/libI77/open.c
View File

@ -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;

14
lib/libI77/rawio.h
View File

@ -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*);

19
lib/libI77/rdfmt.c
View File

@ -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)

13
lib/libI77/rsfe.c
View File

@ -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;

3
lib/libI77/rsli.c
View File

@ -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++);
}

50
lib/libI77/rsne.c
View File

@ -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);

4
lib/libI77/sfe.c
View File

@ -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)

8
lib/libI77/sue.c
View File

@ -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))

5
lib/libI77/uio.c
View File

@ -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;

16
lib/libI77/wref.c
View File

@ -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');

94
lib/libI77/wrtfmt.c
View File

@ -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)

12
lib/libI77/wsfe.c
View File

@ -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;

2
lib/libI77/wsle.c
View File

@ -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;

2
lib/libI77/wsne.c
View File

@ -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
lib/libf2c/Makefile
View File

@ -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 \