wref.c
Go to the documentation of this file.
00001 #include "f2c.h"
00002 #include "fio.h"
00003 
00004 #ifndef KR_headers
00005 #undef abs
00006 #undef min
00007 #undef max
00008 #include "stdlib.h"
00009 #include "string.h"
00010 #endif
00011 
00012 #include "fmt.h"
00013 #include "fp.h"
00014 #ifndef VAX
00015 #include "ctype.h"
00016 #ifdef __cplusplus
00017 extern "C" {
00018 #endif
00019 #endif
00020 
00021  int
00022 #ifdef KR_headers
00023 wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
00024 #else
00025 wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
00026 #endif
00027 {
00028         char buf[FMAX+EXPMAXDIGS+4], *s, *se;
00029         int d1, delta, e1, i, sign, signspace;
00030         double dd;
00031 #ifdef WANT_LEAD_0
00032         int insert0 = 0;
00033 #endif
00034 #ifndef VAX
00035         int e0 = e;
00036 #endif
00037 
00038         if(e <= 0)
00039                 e = 2;
00040         if(f__scale) {
00041                 if(f__scale >= d + 2 || f__scale <= -d)
00042                         goto nogood;
00043                 }
00044         if(f__scale <= 0)
00045                 --d;
00046         if (len == sizeof(real))
00047                 dd = p->pf;
00048         else
00049                 dd = p->pd;
00050         if (dd < 0.) {
00051                 signspace = sign = 1;
00052                 dd = -dd;
00053                 }
00054         else {
00055                 sign = 0;
00056                 signspace = (int)f__cplus;
00057 #ifndef VAX
00058                 if (!dd) {
00059 #ifdef SIGNED_ZEROS
00060                         if (signbit_f2c(&dd))
00061                                 signspace = sign = 1;
00062 #endif
00063                         dd = 0.;        /* avoid -0 */
00064                         }
00065 #endif
00066                 }
00067         delta = w - (2 /* for the . and the d adjustment above */
00068                         + 2 /* for the E+ */ + signspace + d + e);
00069 #ifdef WANT_LEAD_0
00070         if (f__scale <= 0 && delta > 0) {
00071                 delta--;
00072                 insert0 = 1;
00073                 }
00074         else
00075 #endif
00076         if (delta < 0) {
00077 nogood:
00078                 while(--w >= 0)
00079                         PUT('*');
00080                 return(0);
00081                 }
00082         if (f__scale < 0)
00083                 d += f__scale;
00084         if (d > FMAX) {
00085                 d1 = d - FMAX;
00086                 d = FMAX;
00087                 }
00088         else
00089                 d1 = 0;
00090         sprintf(buf,"%#.*E", d, dd);
00091 #ifndef VAX
00092         /* check for NaN, Infinity */
00093         if (!isdigit(buf[0])) {
00094                 switch(buf[0]) {
00095                         case 'n':
00096                         case 'N':
00097                                 signspace = 0;  /* no sign for NaNs */
00098                         }
00099                 delta = w - strlen(buf) - signspace;
00100                 if (delta < 0)
00101                         goto nogood;
00102                 while(--delta >= 0)
00103                         PUT(' ');
00104                 if (signspace)
00105                         PUT(sign ? '-' : '+');
00106                 for(s = buf; *s; s++)
00107                         PUT(*s);
00108                 return 0;
00109                 }
00110 #endif
00111         se = buf + d + 3;
00112 #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
00113         if (f__scale != 1 && dd)
00114                 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
00115 #else
00116         if (dd)
00117                 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
00118         else
00119                 strcpy(se, "+00");
00120 #endif
00121         s = ++se;
00122         if (e < 2) {
00123                 if (*s != '0')
00124                         goto nogood;
00125                 }
00126 #ifndef VAX
00127         /* accommodate 3 significant digits in exponent */
00128         if (s[2]) {
00129 #ifdef Pedantic
00130                 if (!e0 && !s[3])
00131                         for(s -= 2, e1 = 2; s[0] = s[1]; s++);
00132 
00133         /* Pedantic gives the behavior that Fortran 77 specifies,       */
00134         /* i.e., requires that E be specified for exponent fields       */
00135         /* of more than 3 digits.  With Pedantic undefined, we get      */
00136         /* the behavior that Cray displays -- you get a bigger          */
00137         /* exponent field if it fits.   */
00138 #else
00139                 if (!e0) {
00140                         for(s -= 2, e1 = 2; s[0] = s[1]; s++)
00141 #ifdef CRAY
00142                                 delta--;
00143                         if ((delta += 4) < 0)
00144                                 goto nogood
00145 #endif
00146                                 ;
00147                         }
00148 #endif
00149                 else if (e0 >= 0)
00150                         goto shift;
00151                 else
00152                         e1 = e;
00153                 }
00154         else
00155  shift:
00156 #endif
00157                 for(s += 2, e1 = 2; *s; ++e1, ++s)
00158                         if (e1 >= e)
00159                                 goto nogood;
00160         while(--delta >= 0)
00161                 PUT(' ');
00162         if (signspace)
00163                 PUT(sign ? '-' : '+');
00164         s = buf;
00165         i = f__scale;
00166         if (f__scale <= 0) {
00167 #ifdef WANT_LEAD_0
00168                 if (insert0)
00169                         PUT('0');
00170 #endif
00171                 PUT('.');
00172                 for(; i < 0; ++i)
00173                         PUT('0');
00174                 PUT(*s);
00175                 s += 2;
00176                 }
00177         else if (f__scale > 1) {
00178                 PUT(*s);
00179                 s += 2;
00180                 while(--i > 0)
00181                         PUT(*s++);
00182                 PUT('.');
00183                 }
00184         if (d1) {
00185                 se -= 2;
00186                 while(s < se) PUT(*s++);
00187                 se += 2;
00188                 do PUT('0'); while(--d1 > 0);
00189                 }
00190         while(s < se)
00191                 PUT(*s++);
00192         if (e < 2)
00193                 PUT(s[1]);
00194         else {
00195                 while(++e1 <= e)
00196                         PUT('0');
00197                 while(*s)
00198                         PUT(*s++);
00199                 }
00200         return 0;
00201         }
00202 
00203  int
00204 #ifdef KR_headers
00205 wrt_F(p,w,d,len) ufloat *p; ftnlen len;
00206 #else
00207 wrt_F(ufloat *p, int w, int d, ftnlen len)
00208 #endif
00209 {
00210         int d1, sign, n;
00211         double x;
00212         char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
00213 
00214         x= (len==sizeof(real)?p->pf:p->pd);
00215         if (d < MAXFRACDIGS)
00216                 d1 = 0;
00217         else {
00218                 d1 = d - MAXFRACDIGS;
00219                 d = MAXFRACDIGS;
00220                 }
00221         if (x < 0.)
00222                 { x = -x; sign = 1; }
00223         else {
00224                 sign = 0;
00225 #ifndef VAX
00226                 if (!x) {
00227 #ifdef SIGNED_ZEROS
00228                         if (signbit_f2c(&x))
00229                                 sign = 2;
00230 #endif
00231                         x = 0.;
00232                         }
00233 #endif
00234                 }
00235 
00236         if (n = f__scale)
00237                 if (n > 0)
00238                         do x *= 10.; while(--n > 0);
00239                 else
00240                         do x *= 0.1; while(++n < 0);
00241 
00242 #ifdef USE_STRLEN
00243         sprintf(b = buf, "%#.*f", d, x);
00244         n = strlen(b) + d1;
00245 #else
00246         n = sprintf(b = buf, "%#.*f", d, x) + d1;
00247 #endif
00248 
00249 #ifndef WANT_LEAD_0
00250         if (buf[0] == '0' && d)
00251                 { ++b; --n; }
00252 #endif
00253         if (sign == 1) {
00254                 /* check for all zeros */
00255                 for(s = b;;) {
00256                         while(*s == '0') s++;
00257                         switch(*s) {
00258                                 case '.':
00259                                         s++; continue;
00260                                 case 0:
00261                                         sign = 0;
00262                                 }
00263                         break;
00264                         }
00265                 }
00266         if (sign || f__cplus)
00267                 ++n;
00268         if (n > w) {
00269 #ifdef WANT_LEAD_0
00270                 if (buf[0] == '0' && --n == w)
00271                         ++b;
00272                 else
00273 #endif
00274                 {
00275                         while(--w >= 0)
00276                                 PUT('*');
00277                         return 0;
00278                         }
00279                 }
00280         for(w -= n; --w >= 0; )
00281                 PUT(' ');
00282         if (sign)
00283                 PUT('-');
00284         else if (f__cplus)
00285                 PUT('+');
00286         while(n = *b++)
00287                 PUT(n);
00288         while(--d1 >= 0)
00289                 PUT('0');
00290         return 0;
00291         }
00292 #ifdef __cplusplus
00293 }
00294 #endif


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:56:16