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

libf2c/ChangeLog

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

libf2c/libF77/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>

libf2c/libF77/dtime_.c

@@ -45,8 +45,8 @@ dtime_(float *tarray)
 	static struct tms t0;
 
 	times(&t);
-	tarray[0] = (t.tms_utime - t0.tms_utime) / Hz;
+	tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz;
-	tarray[1] = (t.tms_stime - t0.tms_stime) / Hz;
+	tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz;
 	t0 = t;
 	return tarray[0] + tarray[1];
 #endif

libf2c/libF77/etime_.c

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

libf2c/libF77/s_cat.c

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

libf2c/libF77/z_log.c

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

libf2c/libI77/Version.c

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

libf2c/libI77/lread.c

@@ -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;
+	int ch, rv, sawdot;
-	if(f__lcount>0) return(0);
+	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:

libf2c/libI77/rsne.c

@@ -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;
+	ftnlen b, b0, b1, ex, no, nomax, size, span;
-	ftnint type;
+	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;
 			}

libf2c/libI77/xwsne.c

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