summaryrefslogtreecommitdiffstats
path: root/lib/libI77/wref.c
diff options
context:
space:
mode:
Diffstat (limited to 'lib/libI77/wref.c')
-rw-r--r--lib/libI77/wref.c247
1 files changed, 247 insertions, 0 deletions
diff --git a/lib/libI77/wref.c b/lib/libI77/wref.c
new file mode 100644
index 0000000..1ef2c47
--- /dev/null
+++ b/lib/libI77/wref.c
@@ -0,0 +1,247 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "fp.h"
+#ifndef VAX
+#include "ctype.h"
+#endif
+
+#ifndef KR_headers
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#include "string.h"
+#endif
+
+#ifdef KR_headers
+wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
+#else
+wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
+#endif
+{
+ char buf[FMAX+EXPMAXDIGS+4], *s, *se;
+ int d1, delta, e1, i, sign, signspace;
+ double dd;
+#ifndef VAX
+ int e0 = e;
+#endif
+
+ if(e <= 0)
+ e = 2;
+ if(f__scale) {
+ if(f__scale >= d + 2 || f__scale <= -d)
+ goto nogood;
+ }
+ if(f__scale <= 0)
+ --d;
+ if (len == sizeof(real))
+ dd = p->pf;
+ else
+ dd = p->pd;
+ if (dd < 0.) {
+ signspace = sign = 1;
+ dd = -dd;
+ }
+ else {
+ sign = 0;
+ signspace = (int)f__cplus;
+#ifndef VAX
+ if (!dd)
+ dd = 0.; /* avoid -0 */
+#endif
+ }
+ delta = w - (2 /* for the . and the d adjustment above */
+ + 2 /* for the E+ */ + signspace + d + e);
+ if (delta < 0) {
+nogood:
+ while(--w >= 0)
+ PUT('*');
+ return(0);
+ }
+ if (f__scale < 0)
+ d += f__scale;
+ if (d > FMAX) {
+ d1 = d - FMAX;
+ d = FMAX;
+ }
+ else
+ d1 = 0;
+ sprintf(buf,"%#.*E", d, dd);
+#ifndef VAX
+ /* check for NaN, Infinity */
+ if (!isdigit(buf[0])) {
+ switch(buf[0]) {
+ case 'n':
+ case 'N':
+ signspace = 0; /* no sign for NaNs */
+ }
+ delta = w - strlen(buf) - signspace;
+ if (delta < 0)
+ goto nogood;
+ while(--delta >= 0)
+ PUT(' ');
+ if (signspace)
+ PUT(sign ? '-' : '+');
+ for(s = buf; *s; s++)
+ PUT(*s);
+ return 0;
+ }
+#endif
+ se = buf + d + 3;
+#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
+ if (f__scale != 1 && dd)
+#endif
+ sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
+ s = ++se;
+ if (e < 2) {
+ if (*s != '0')
+ goto nogood;
+ }
+#ifndef VAX
+ /* accommodate 3 significant digits in exponent */
+ if (s[2]) {
+#ifdef Pedantic
+ if (!e0 && !s[3])
+ for(s -= 2, e1 = 2; s[0] = s[1]; s++);
+
+ /* Pedantic gives the behavior that Fortran 77 specifies, */
+ /* i.e., requires that E be specified for exponent fields */
+ /* of more than 3 digits. With Pedantic undefined, we get */
+ /* the behavior that Cray displays -- you get a bigger */
+ /* exponent field if it fits. */
+#else
+ if (!e0) {
+ for(s -= 2, e1 = 2; s[0] = s[1]; s++)
+#ifdef CRAY
+ delta--;
+ if ((delta += 4) < 0)
+ goto nogood
+#endif
+ ;
+ }
+#endif
+ else if (e0 >= 0)
+ goto shift;
+ else
+ e1 = e;
+ }
+ else
+ shift:
+#endif
+ for(s += 2, e1 = 2; *s; ++e1, ++s)
+ if (e1 >= e)
+ goto nogood;
+ while(--delta >= 0)
+ PUT(' ');
+ if (signspace)
+ PUT(sign ? '-' : '+');
+ s = buf;
+ i = f__scale;
+ if (f__scale <= 0) {
+ PUT('.');
+ for(; i < 0; ++i)
+ PUT('0');
+ PUT(*s);
+ s += 2;
+ }
+ else if (f__scale > 1) {
+ PUT(*s);
+ s += 2;
+ while(--i > 0)
+ PUT(*s++);
+ PUT('.');
+ }
+ if (d1) {
+ se -= 2;
+ while(s < se) PUT(*s++);
+ se += 2;
+ do PUT('0'); while(--d1 > 0);
+ }
+ while(s < se)
+ PUT(*s++);
+ if (e < 2)
+ PUT(s[1]);
+ else {
+ while(++e1 <= e)
+ PUT('0');
+ while(*s)
+ PUT(*s++);
+ }
+ return 0;
+ }
+
+#ifdef KR_headers
+wrt_F(p,w,d,len) ufloat *p; ftnlen len;
+#else
+wrt_F(ufloat *p, int w, int d, ftnlen len)
+#endif
+{
+ int d1, sign, n;
+ double x;
+ char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
+
+ x= (len==sizeof(real)?p->pf:p->pd);
+ if (d < MAXFRACDIGS)
+ d1 = 0;
+ else {
+ d1 = d - MAXFRACDIGS;
+ d = MAXFRACDIGS;
+ }
+ if (x < 0.)
+ { x = -x; sign = 1; }
+ else {
+ sign = 0;
+#ifndef VAX
+ if (!x)
+ x = 0.;
+#endif
+ }
+
+ if (n = f__scale)
+ if (n > 0)
+ do x *= 10.; while(--n > 0);
+ else
+ do x *= 0.1; while(++n < 0);
+
+#ifdef USE_STRLEN
+ sprintf(b = buf, "%#.*f", d, x);
+ n = strlen(b) + d1;
+#else
+ n = sprintf(b = buf, "%#.*f", d, x) + d1;
+#endif
+
+ if (buf[0] == '0' && d)
+ { ++b; --n; }
+ if (sign) {
+ /* check for all zeros */
+ for(s = b;;) {
+ while(*s == '0') s++;
+ switch(*s) {
+ case '.':
+ s++; continue;
+ case 0:
+ sign = 0;
+ }
+ break;
+ }
+ }
+ if (sign || f__cplus)
+ ++n;
+ if (n > w) {
+ while(--w >= 0)
+ PUT('*');
+ return 0;
+ }
+ for(w -= n; --w >= 0; )
+ PUT(' ');
+ if (sign)
+ PUT('-');
+ else if (f__cplus)
+ PUT('+');
+ while(n = *b++)
+ PUT(n);
+ while(--d1 >= 0)
+ PUT('0');
+ return 0;
+ }
OpenPOWER on IntegriCloud