Update to Netlib version 20001205.
2000-12-09 Toon Moene <toon@moene.indiv.nluug.nl> Update to Netlib version 20001205. Thanks go to David M. Gay for these updates. * libF77/Version.c: Update version information. * libF77/z_log.c: Improve accuracy of real(log(z)) for z near (+-1,eps) with |eps| small. * libF77/s_cat.c: Adjust call when ftnint and ftnlen are of different size. * libF77/dtime_.c, libF77/etime_.c: Use floating point divide. * libI77/Version.c: Update version information. * libI77/rsne.c, libI77/xwsne.c: Adjust code for when ftnint and ftnlen differ in size. * libI77/lread.c: Fix reading of namelist logical values followed by <name>= where <name> starts with T or F. From-SVN: r38152
This commit is contained in:
Toon Moene
Toon Moene
parent
9766549120
commit
a40bb4d345
@ -1,3 +1,21 @@
|
||||
2000-12-09 Toon Moene <toon@moene.indiv.nluug.nl>
|
||||
|
||||
Update to Netlib version 20001205.
|
||||
Thanks go to David M. Gay for these updates.
|
||||
|
||||
* libF77/Version.c: Update version information.
|
||||
* libF77/z_log.c: Improve accuracy of real(log(z)) for
|
||||
z near (+-1,eps) with |eps| small.
|
||||
* libF77/s_cat.c: Adjust call when ftnint and ftnlen are
|
||||
of different size.
|
||||
* libF77/dtime_.c, libF77/etime_.c: Use floating point divide.
|
||||
|
||||
* libI77/Version.c: Update version information.
|
||||
* libI77/rsne.c, libI77/xwsne.c: Adjust code for when ftnint
|
||||
and ftnlen differ in size.
|
||||
* libI77/lread.c: Fix reading of namelist logical values followed
|
||||
by <name>= where <name> starts with T or F.
|
||||
|
||||
2000-11-26 Toon Moene <toon@moene.indiv.nluug.nl>
|
||||
|
||||
* libI77/Version.c, libF77/Version.c, libU77/Version.c:
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
static char junk[] = "\n@(#)LIBF77 VERSION 19991115\n";
|
||||
static char junk[] = "\n@(#)LIBF77 VERSION 20000929\n";
|
||||
|
||||
/*
|
||||
*/
|
||||
@ -69,6 +69,17 @@ char __G77_LIBF77_VERSION__[] = "0.5.26 20001209 (experimental)";
|
||||
also vanishes or not. VERSION not changed.
|
||||
15 Nov. 1999: s_rnge.c: add casts for the case of
|
||||
sizeof(ftnint) == sizeof(int) < sizeof(long).
|
||||
10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g.,
|
||||
z near (+-1,eps) with |eps| small. For the old
|
||||
evaluation, compile with -DPre20000310 .
|
||||
20 April 2000: s_cat.c: tweak argument types to accord with
|
||||
calls by f2c when ftnint and ftnlen are of
|
||||
different sizes (different numbers of bits).
|
||||
4 July 2000: adjustments to permit compilation by C++ compilers;
|
||||
VERSION string remains unchanged. NOT APPLIED FOR G77.
|
||||
29 Sept. 2000: dtime_.c, etime_.c: use floating-point divide.
|
||||
dtime_.d, erf_.c, erfc_.c, etime.c: for use with
|
||||
"f2c -R", compile with -DREAL=float.
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
@ -45,8 +45,8 @@ dtime_(float *tarray)
|
||||
static struct tms t0;
|
||||
|
||||
times(&t);
|
||||
tarray[0] = (t.tms_utime - t0.tms_utime) / Hz;
|
||||
tarray[1] = (t.tms_stime - t0.tms_stime) / Hz;
|
||||
tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz;
|
||||
tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz;
|
||||
t0 = t;
|
||||
return tarray[0] + tarray[1];
|
||||
#endif
|
||||
|
||||
@ -41,6 +41,7 @@ etime_(float *tarray)
|
||||
struct tms t;
|
||||
|
||||
times(&t);
|
||||
return (tarray[0] = t.tms_utime/Hz) + (tarray[1] = t.tms_stime/Hz);
|
||||
return (tarray[0] = (double)t.tms_utime/Hz)
|
||||
+ (tarray[1] = (double)t.tms_stime/Hz);
|
||||
#endif
|
||||
}
|
||||
|
||||
@ -22,9 +22,9 @@
|
||||
|
||||
VOID
|
||||
#ifdef KR_headers
|
||||
s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnlen rnp[], *np, ll;
|
||||
s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll;
|
||||
#else
|
||||
s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll)
|
||||
s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll)
|
||||
#endif
|
||||
{
|
||||
ftnlen i, nc;
|
||||
|
||||
@ -10,7 +10,54 @@ extern double f__cabs(double, double);
|
||||
void z_log(doublecomplex *r, doublecomplex *z)
|
||||
#endif
|
||||
{
|
||||
double s, s0, t, t2, u, v;
|
||||
double zi = z->i, zr = z->r;
|
||||
|
||||
r->i = atan2(zi, zr);
|
||||
#ifdef Pre20000310
|
||||
r->r = log( f__cabs( zr, zi ) );
|
||||
#else
|
||||
if (zi < 0)
|
||||
zi = -zi;
|
||||
if (zr < 0)
|
||||
zr = -zr;
|
||||
if (zr < zi) {
|
||||
t = zi;
|
||||
zi = zr;
|
||||
zr = t;
|
||||
}
|
||||
t = zi/zr;
|
||||
s = zr * sqrt(1 + t*t);
|
||||
/* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */
|
||||
if ((t = s - 1) < 0)
|
||||
t = -t;
|
||||
if (t > .01)
|
||||
r->r = log(s);
|
||||
else {
|
||||
|
||||
#ifdef Comment
|
||||
|
||||
log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ...
|
||||
|
||||
= x(1 - x/2 + x^2/3 -+...)
|
||||
|
||||
[sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so
|
||||
|
||||
sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1]
|
||||
|
||||
#endif /*Comment*/
|
||||
|
||||
t = ((zr*zr - 1.) + zi*zi) / (s + 1);
|
||||
t2 = t*t;
|
||||
s = 1. - 0.5*t;
|
||||
u = v = 1;
|
||||
do {
|
||||
s0 = s;
|
||||
u *= t2;
|
||||
v += 2;
|
||||
s += u/v - t*u/(v+1);
|
||||
} while(s > s0);
|
||||
r->r = s*t;
|
||||
}
|
||||
#endif
|
||||
}
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19991115\n";
|
||||
static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 20001205\n";
|
||||
|
||||
/*
|
||||
*/
|
||||
@ -314,6 +314,15 @@ wrtfmt.c:
|
||||
/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */
|
||||
/* any data in buffers should the program fault. It also */
|
||||
/* makes the program run more slowly. */
|
||||
/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */
|
||||
/* ftnlen are of different fundamental types (different numbers */
|
||||
/* of bits). Since these files will not compile when this */
|
||||
/* change matters, the above VERSION string remains unchanged. */
|
||||
/* 4 July 2000: adjustments to permit compilation by C++ compilers; */
|
||||
/* VERSION string remains unchanged. NOT APPLIED FOR G77 */
|
||||
/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */
|
||||
/* treat Tstuff= and Fstuff= as new assignments rather than as */
|
||||
/* logical constants. */
|
||||
|
||||
|
||||
|
||||
|
||||
@ -339,11 +339,93 @@ l_C(Void)
|
||||
return(0);
|
||||
}
|
||||
|
||||
static char nmLbuf[256], *nmL_next;
|
||||
static int (*nmL_getc_save)(Void);
|
||||
#ifdef KR_headers
|
||||
static int (*nmL_ungetc_save)(/* int, FILE* */);
|
||||
#else
|
||||
static int (*nmL_ungetc_save)(int, FILE*);
|
||||
#endif
|
||||
|
||||
static int
|
||||
nmL_getc(Void)
|
||||
{
|
||||
int rv;
|
||||
if (rv = *nmL_next++)
|
||||
return rv;
|
||||
l_getc = nmL_getc_save;
|
||||
l_ungetc = nmL_ungetc_save;
|
||||
return (*l_getc)();
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
nmL_ungetc(x, f) int x; FILE *f;
|
||||
#else
|
||||
nmL_ungetc(int x, FILE *f)
|
||||
#endif
|
||||
{
|
||||
f = f; /* banish non-use warning */
|
||||
return *--nmL_next = x;
|
||||
}
|
||||
|
||||
static int
|
||||
#ifdef KR_headers
|
||||
Lfinish(ch, dot, rvp) int ch, dot, *rvp;
|
||||
#else
|
||||
Lfinish(int ch, int dot, int *rvp)
|
||||
#endif
|
||||
{
|
||||
char *s, *se;
|
||||
static char what[] = "namelist input";
|
||||
|
||||
s = nmLbuf + 2;
|
||||
se = nmLbuf + sizeof(nmLbuf) - 1;
|
||||
*s++ = ch;
|
||||
while(!issep(GETC(ch)) && ch!=EOF) {
|
||||
if (s >= se) {
|
||||
nmLbuf_ovfl:
|
||||
return *rvp = err__fl(f__elist->cierr,131,what);
|
||||
}
|
||||
*s++ = ch;
|
||||
if (ch != '=')
|
||||
continue;
|
||||
if (dot)
|
||||
return *rvp = err__fl(f__elist->cierr,112,what);
|
||||
got_eq:
|
||||
*s = 0;
|
||||
nmL_getc_save = l_getc;
|
||||
l_getc = nmL_getc;
|
||||
nmL_ungetc_save = l_ungetc;
|
||||
l_ungetc = nmL_ungetc;
|
||||
nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
|
||||
*rvp = f__lcount = 0;
|
||||
return 1;
|
||||
}
|
||||
if (dot)
|
||||
goto done;
|
||||
for(;;) {
|
||||
if (s >= se)
|
||||
goto nmLbuf_ovfl;
|
||||
*s++ = ch;
|
||||
if (!isblnk(ch))
|
||||
break;
|
||||
if (GETC(ch) == EOF)
|
||||
goto done;
|
||||
}
|
||||
if (ch == '=')
|
||||
goto got_eq;
|
||||
done:
|
||||
Ungetc(ch, f__cf);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
l_L(Void)
|
||||
{
|
||||
int ch;
|
||||
if(f__lcount>0) return(0);
|
||||
int ch, rv, sawdot;
|
||||
if(f__lcount>0)
|
||||
return(0);
|
||||
f__lcount = 1;
|
||||
f__ltype=0;
|
||||
GETC(ch);
|
||||
@ -357,15 +439,23 @@ l_L(Void)
|
||||
err(f__elist->cierr,(EOF),"lread");
|
||||
GETC(ch);
|
||||
}
|
||||
if(ch == '.') GETC(ch);
|
||||
sawdot = 0;
|
||||
if(ch == '.') {
|
||||
sawdot = 1;
|
||||
GETC(ch);
|
||||
}
|
||||
switch(ch)
|
||||
{
|
||||
case 't':
|
||||
case 'T':
|
||||
if (nml_read && Lfinish(ch, sawdot, &rv))
|
||||
return rv;
|
||||
f__lx=1;
|
||||
break;
|
||||
case 'f':
|
||||
case 'F':
|
||||
if (nml_read && Lfinish(ch, sawdot, &rv))
|
||||
return rv;
|
||||
f__lx=0;
|
||||
break;
|
||||
default:
|
||||
|
||||
@ -302,8 +302,8 @@ x_rsne(cilist *a)
|
||||
Vardesc *v;
|
||||
dimen *dn, *dn0, *dn1;
|
||||
ftnlen *dims, *dims1;
|
||||
ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
|
||||
ftnint type;
|
||||
ftnlen b, b0, b1, ex, no, nomax, size, span;
|
||||
ftnint no1, type;
|
||||
char *vaddr;
|
||||
long iva, ivae;
|
||||
dimen dimens[MAXDIM], substr;
|
||||
@ -338,7 +338,7 @@ x_rsne(cilist *a)
|
||||
#endif
|
||||
}
|
||||
have_amp:
|
||||
if (ch = getname(buf,(int) sizeof(buf)))
|
||||
if (ch = getname(buf,sizeof(buf)))
|
||||
return ch;
|
||||
nl = (Namelist *)a->cifmt;
|
||||
if (strcmp(buf, nl->name))
|
||||
@ -393,7 +393,7 @@ x_rsne(cilist *a)
|
||||
if (ch <= ' ' && ch >= 0 || ch == ',')
|
||||
continue;
|
||||
Ungetc(ch,f__cf);
|
||||
if (ch = getname(buf,(int) sizeof(buf)))
|
||||
if (ch = getname(buf,sizeof(buf)))
|
||||
return ch;
|
||||
goto havename;
|
||||
}
|
||||
|
||||
@ -24,10 +24,9 @@ x_wsne(cilist *a)
|
||||
Namelist *nl;
|
||||
char *s;
|
||||
Vardesc *v, **vd, **vde;
|
||||
ftnint *number, type;
|
||||
ftnint number, type;
|
||||
ftnlen *dims;
|
||||
ftnlen size;
|
||||
static ftnint one = 1;
|
||||
extern ftnlen f__typesize[];
|
||||
|
||||
nl = (Namelist *)a->cifmt;
|
||||
@ -49,7 +48,7 @@ x_wsne(cilist *a)
|
||||
PUT(*s++);
|
||||
PUT(' ');
|
||||
PUT('=');
|
||||
number = (dims = v->dims) ? dims + 1 : &one;
|
||||
number = (dims = v->dims) ? dims[1] : 1;
|
||||
type = v->type;
|
||||
if (type < 0) {
|
||||
size = -type;
|
||||
@ -57,7 +56,7 @@ x_wsne(cilist *a)
|
||||
}
|
||||
else
|
||||
size = f__typesize[type];
|
||||
l_write(number, v->addr, size, type);
|
||||
l_write(&number, v->addr, size, type);
|
||||
if (vd < vde) {
|
||||
if (f__recpos+2 >= L_len)
|
||||
nl_donewrec();
|
||||
|
||||
Loading…
Reference in New Issue
Block a user