contrib/libf2c/libI77/wref.c

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