Return to wref.c CVS log

Up to [Research Unix] / researchv10dc / libI77

Annotation of researchv10dc/libI77/wref.c, revision 1.1

1.1     ! root        1: #include "f2c.h"
        !             2: #include "fio.h"
        !             3: #include "fmt.h"
        !             4: #include "fp.h"
        !             5: #ifndef VAX
        !             6: #include "ctype.h"
        !             7: #endif
        !             8: 
        !             9: #ifndef KR_headers
        !            10: #undef abs
        !            11: #undef min
        !            12: #undef max
        !            13: #include "stdlib.h"
        !            14: #include "string.h"
        !            15: #endif
        !            16: 
        !            17: #ifdef KR_headers
        !            18: wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
        !            19: #else
        !            20: wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
        !            21: #endif
        !            22: {
        !            23:        char buf[FMAX+EXPMAXDIGS+4], *s, *se;
        !            24:        int d1, delta, e1, i, sign, signspace;
        !            25:        double dd;
        !            26: #ifndef VAX
        !            27:        int e0 = e;
        !            28: #endif
        !            29: 
        !            30:        if(e <= 0)
        !            31:                e = 2;
        !            32:        if(f__scale) {
        !            33:                if(f__scale >= d + 2 || f__scale <= -d)
        !            34:                        goto nogood;
        !            35:                }
        !            36:        if(f__scale <= 0)
        !            37:                --d;
        !            38:        if (len == sizeof(real))
        !            39:                dd = p->pf;
        !            40:        else
        !            41:                dd = p->pd;
        !            42:        if (dd < 0.) {
        !            43:                signspace = sign = 1;
        !            44:                dd = -dd;
        !            45:                }
        !            46:        else {
        !            47:                sign = 0;
        !            48:                signspace = (int)f__cplus;
        !            49: #ifndef VAX
        !            50:                if (!dd)
        !            51:                        dd = 0.;        /* avoid -0 */
        !            52: #endif
        !            53:                }
        !            54:        delta = w - (2 /* for the . and the d adjustment above */
        !            55:                        + 2 /* for the E+ */ + signspace + d + e);
        !            56:        if (delta < 0) {
        !            57: nogood:
        !            58:                while(--w >= 0)
        !            59:                        PUT('*');
        !            60:                return(0);
        !            61:                }
        !            62:        if (f__scale < 0)
        !            63:                d += f__scale;
        !            64:        if (d > FMAX) {
        !            65:                d1 = d - FMAX;
        !            66:                d = FMAX;
        !            67:                }
        !            68:        else
        !            69:                d1 = 0;
        !            70:        sprintf(buf,"%#.*E", d, dd);
        !            71: #ifndef VAX
        !            72:        /* check for NaN, Infinity */
        !            73:        if (!isdigit(buf[0])) {
        !            74:                switch(buf[0]) {
        !            75:                        case 'n':
        !            76:                        case 'N':
        !            77:                                signspace = 0;  /* no sign for NaNs */
        !            78:                        }
        !            79:                delta = w - strlen(buf) - signspace;
        !            80:                if (delta < 0)
        !            81:                        goto nogood;
        !            82:                while(--delta >= 0)
        !            83:                        PUT(' ');
        !            84:                if (signspace)
        !            85:                        PUT(sign ? '-' : '+');
        !            86:                for(s = buf; *s; s++)
        !            87:                        PUT(*s);
        !            88:                return 0;
        !            89:                }
        !            90: #endif
        !            91:        se = buf + d + 3;
        !            92:        if (f__scale != 1 && dd)
        !            93:                sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
        !            94:        s = ++se;
        !            95:        if (e < 2) {
        !            96:                if (*s != '0')
        !            97:                        goto nogood;
        !            98:                }
        !            99: #ifndef VAX
        !           100:        /* accommodate 3 significant digits in exponent */
        !           101:        if (s[2]) {
        !           102: #ifdef Pedantic
        !           103:                if (!e0 && !s[3])
        !           104:                        for(s -= 2, e1 = 2; s[0] = s[1]; s++);
        !           105: 
        !           106:        /* Pedantic gives the behavior that Fortran 77 specifies,       */
        !           107:        /* i.e., requires that E be specified for exponent fields       */
        !           108:        /* of more than 3 digits.  With Pedantic undefined, we get      */
        !           109:        /* the behavior that Cray displays -- you get a bigger          */
        !           110:        /* exponent field if it fits.   */
        !           111: #else
        !           112:                if (!e0) {
        !           113:                        for(s -= 2, e1 = 2; s[0] = s[1]; s++)
        !           114: #ifdef CRAY
        !           115:                                delta--;
        !           116:                        if ((delta += 4) < 0)
        !           117:                                goto nogood
        !           118: #endif
        !           119:                                ;
        !           120:                        }
        !           121: #endif
        !           122:                else if (e0 >= 0)
        !           123:                        goto shift;
        !           124:                else
        !           125:                        e1 = e;
        !           126:                }
        !           127:        else
        !           128:  shift:
        !           129: #endif
        !           130:                for(s += 2, e1 = 2; *s; ++e1, ++s)
        !           131:                        if (e1 >= e)
        !           132:                                goto nogood;
        !           133:        while(--delta >= 0)
        !           134:                PUT(' ');
        !           135:        if (signspace)
        !           136:                PUT(sign ? '-' : '+');
        !           137:        s = buf;
        !           138:        i = f__scale;
        !           139:        if (f__scale <= 0) {
        !           140:                PUT('.');
        !           141:                for(; i < 0; ++i)
        !           142:                        PUT('0');
        !           143:                PUT(*s);
        !           144:                s += 2;
        !           145:                }
        !           146:        else if (f__scale > 1) {
        !           147:                PUT(*s);
        !           148:                s += 2;
        !           149:                while(--i > 0)
        !           150:                        PUT(*s++);
        !           151:                PUT('.');
        !           152:                }
        !           153:        if (d1) {
        !           154:                se -= 2;
        !           155:                while(s < se) PUT(*s++);
        !           156:                se += 2;
        !           157:                do PUT('0'); while(--d1 > 0);
        !           158:                }
        !           159:        while(s < se)
        !           160:                PUT(*s++);
        !           161:        if (e < 2)
        !           162:                PUT(s[1]);
        !           163:        else {
        !           164:                while(++e1 <= e)
        !           165:                        PUT('0');
        !           166:                while(*s)
        !           167:                        PUT(*s++);
        !           168:                }
        !           169:        return 0;
        !           170:        }
        !           171: 
        !           172: #ifdef KR_headers
        !           173: wrt_F(p,w,d,len) ufloat *p; ftnlen len;
        !           174: #else
        !           175: wrt_F(ufloat *p, int w, int d, ftnlen len)
        !           176: #endif
        !           177: {
        !           178:        int d1, sign, n;
        !           179:        double x;
        !           180:        char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
        !           181: 
        !           182:        x= (len==sizeof(real)?p->pf:p->pd);
        !           183:        if (d < MAXFRACDIGS)
        !           184:                d1 = 0;
        !           185:        else {
        !           186:                d1 = d - MAXFRACDIGS;
        !           187:                d = MAXFRACDIGS;
        !           188:                }
        !           189:        if (x < 0.)
        !           190:                { x = -x; sign = 1; }
        !           191:        else {
        !           192:                sign = 0;
        !           193: #ifndef VAX
        !           194:                if (!x)
        !           195:                        x = 0.;
        !           196: #endif
        !           197:                }
        !           198: 
        !           199:        if (n = f__scale)
        !           200:                if (n > 0)
        !           201:                        do x *= 10.; while(--n > 0);
        !           202:                else
        !           203:                        do x *= 0.1; while(++n < 0);
        !           204: 
        !           205: #ifdef USE_STRLEN
        !           206:        sprintf(b = buf, "%#.*f", d, x);
        !           207:        n = strlen(b) + d1;
        !           208: #else
        !           209:        n = sprintf(b = buf, "%#.*f", d, x) + d1;
        !           210: #endif
        !           211: 
        !           212:        if (buf[0] == '0' && d)
        !           213:                { ++b; --n; }
        !           214:        if (sign) {
        !           215:                /* check for all zeros */
        !           216:                for(s = b;;) {
        !           217:                        while(*s == '0') s++;
        !           218:                        switch(*s) {
        !           219:                                case '.':
        !           220:                                        s++; continue;
        !           221:                                case 0:
        !           222:                                        sign = 0;
        !           223:                                }
        !           224:                        break;
        !           225:                        }
        !           226:                }
        !           227:        if (sign || f__cplus)
        !           228:                ++n;
        !           229:        if (n > w) {
        !           230:                while(--w >= 0)
        !           231:                        PUT('*');
        !           232:                return 0;
        !           233:                }
        !           234:        for(w -= n; --w >= 0; )
        !           235:                PUT(' ');
        !           236:        if (sign)
        !           237:                PUT('-');
        !           238:        else if (f__cplus)
        !           239:                PUT('+');
        !           240:        while(n = *b++)
        !           241:                PUT(n);
        !           242:        while(--d1 >= 0)
        !           243:                PUT('0');
        !           244:        return 0;
        !           245:        }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.