wref.c   [plain text]

#include "f2c.h"
#include "fio.h"
#ifndef VAX
#include <ctype.h>
#endif

#undef abs
#undef min
#undef max
#include <stdlib.h>
#include <string.h>

#include "fmt.h"
#include "fp.h"

int
wrt_E (ufloat * p, int w, int d, int e, ftnlen len)
{
  char buf[FMAX + EXPMAXDIGS + 4], *s, *se;
  int d1, delta, e1, i, sign, signspace;
  double dd;
#ifdef WANT_LEAD_0
  int insert0 = 0;
#endif
#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);
#ifdef WANT_LEAD_0
  if (f__scale <= 0 && delta > 0)
    {
      delta--;
      insert0 = 1;
    }
  else
#endif
  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 ((unsigned char) 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)
    sprintf (se, "%+.2d", atoi (se) + 1 - f__scale);
#else
  if (dd)
    sprintf (se, "%+.2d", atoi (se) + 1 - f__scale);
  else
    strcpy (se, "+00");
#endif
  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)
    {
#ifdef WANT_LEAD_0
      if (insert0)
	PUT ('0');
#endif
      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;
}

int
wrt_F (ufloat * p, int w, int d, ftnlen len)
{
  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

#ifndef WANT_LEAD_0
  if (buf[0] == '0' && d)
    {
      ++b;
      --n;
    }
#endif
  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)
    {
#ifdef WANT_LEAD_0
      if (buf[0] == '0' && --n == w)
	++b;
      else
#endif
	{
	  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;
}