wref.c

Go to the documentation of this file.

#include "f2c.h"
#include "fio.h"

#ifndef KR_headers
#undef abs
#undef min
#undef max
#include "stdlib.h"
#include "string.h"
#endif

#include "fmt.h"
#include "fp.h"
#ifndef VAX
#include "ctype.h"
#ifdef __cplusplus
extern "C" {
#endif
#endif

 int
#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;
#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) {
#ifdef SIGNED_ZEROS
                        if (signbit_f2c(&dd))
                                signspace = sign = 1;
#endif
                        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(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
#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) {
#ifdef SIGNED_ZEROS
                        if (signbit_f2c(&x))
                                sign = 2;
#endif
                        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 == 1) {
                /* 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;
        }
#ifdef __cplusplus
}
#endif