lang/fortran/lib/libI77/wref.c

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