home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / g77-0.5.15-src.tgz / tar.out / fsf / g77 / f / runtime / libI77 / wref.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  4KB  |  253 lines
  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. #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
  93.     if (f__scale != 1 && dd)
  94.         sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
  95. #else
  96.     if (dd)
  97.         sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
  98.     else
  99.         strcpy(se, "+00");
  100. #endif
  101.     s = ++se;
  102.     if (e < 2) {
  103.         if (*s != '0')
  104.             goto nogood;
  105.         }
  106. #ifndef VAX
  107.     /* accommodate 3 significant digits in exponent */
  108.     if (s[2]) {
  109. #ifdef Pedantic
  110.         if (!e0 && !s[3])
  111.             for(s -= 2, e1 = 2; s[0] = s[1]; s++);
  112.  
  113.     /* Pedantic gives the behavior that Fortran 77 specifies,    */
  114.     /* i.e., requires that E be specified for exponent fields    */
  115.     /* of more than 3 digits.  With Pedantic undefined, we get    */
  116.     /* the behavior that Cray displays -- you get a bigger        */
  117.     /* exponent field if it fits.    */
  118. #else
  119.         if (!e0) {
  120.             for(s -= 2, e1 = 2; s[0] = s[1]; s++)
  121. #ifdef CRAY
  122.                 delta--;
  123.             if ((delta += 4) < 0)
  124.                 goto nogood
  125. #endif
  126.                 ;
  127.             }
  128. #endif
  129.         else if (e0 >= 0)
  130.             goto shift;
  131.         else
  132.             e1 = e;
  133.         }
  134.     else
  135.  shift:
  136. #endif
  137.         for(s += 2, e1 = 2; *s; ++e1, ++s)
  138.             if (e1 >= e)
  139.                 goto nogood;
  140.     while(--delta >= 0)
  141.         PUT(' ');
  142.     if (signspace)
  143.         PUT(sign ? '-' : '+');
  144.     s = buf;
  145.     i = f__scale;
  146.     if (f__scale <= 0) {
  147.         PUT('.');
  148.         for(; i < 0; ++i)
  149.             PUT('0');
  150.         PUT(*s);
  151.         s += 2;
  152.         }
  153.     else if (f__scale > 1) {
  154.         PUT(*s);
  155.         s += 2;
  156.         while(--i > 0)
  157.             PUT(*s++);
  158.         PUT('.');
  159.         }
  160.     if (d1) {
  161.         se -= 2;
  162.         while(s < se) PUT(*s++);
  163.         se += 2;
  164.         do PUT('0'); while(--d1 > 0);
  165.         }
  166.     while(s < se)
  167.         PUT(*s++);
  168.     if (e < 2)
  169.         PUT(s[1]);
  170.     else {
  171.         while(++e1 <= e)
  172.             PUT('0');
  173.         while(*s)
  174.             PUT(*s++);
  175.         }
  176.     return 0;
  177.     }
  178.  
  179. #ifdef KR_headers
  180. wrt_F(p,w,d,len) ufloat *p; ftnlen len;
  181. #else
  182. wrt_F(ufloat *p, int w, int d, ftnlen len)
  183. #endif
  184. {
  185.     int d1, sign, n;
  186.     double x;
  187.     char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
  188.  
  189.     x= (len==sizeof(real)?p->pf:p->pd);
  190.     if (d < MAXFRACDIGS)
  191.         d1 = 0;
  192.     else {
  193.         d1 = d - MAXFRACDIGS;
  194.         d = MAXFRACDIGS;
  195.         }
  196.     if (x < 0.)
  197.         { x = -x; sign = 1; }
  198.     else {
  199.         sign = 0;
  200. #ifndef VAX
  201.         if (!x)
  202.             x = 0.;
  203. #endif
  204.         }
  205.  
  206.     if (n = f__scale)
  207.         if (n > 0)
  208.             do x *= 10.; while(--n > 0);
  209.         else
  210.             do x *= 0.1; while(++n < 0);
  211.  
  212. #ifdef USE_STRLEN
  213.     sprintf(b = buf, "%#.*f", d, x);
  214.     n = strlen(b) + d1;
  215. #else
  216.     n = sprintf(b = buf, "%#.*f", d, x) + d1;
  217. #endif
  218.  
  219.     if (buf[0] == '0' && d)
  220.         { ++b; --n; }
  221.     if (sign) {
  222.         /* check for all zeros */
  223.         for(s = b;;) {
  224.             while(*s == '0') s++;
  225.             switch(*s) {
  226.                 case '.':
  227.                     s++; continue;
  228.                 case 0:
  229.                     sign = 0;
  230.                 }
  231.             break;
  232.             }
  233.         }
  234.     if (sign || f__cplus)
  235.         ++n;
  236.     if (n > w) {
  237.         while(--w >= 0)
  238.             PUT('*');
  239.         return 0;
  240.         }
  241.     for(w -= n; --w >= 0; )
  242.         PUT(' ');
  243.     if (sign)
  244.         PUT('-');
  245.     else if (f__cplus)
  246.         PUT('+');
  247.     while(n = *b++)
  248.         PUT(n);
  249.     while(--d1 >= 0)
  250.         PUT('0');
  251.     return 0;
  252.     }
  253.