lang/fortran/lib/libI77/lwrite.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #include "fmt.h"
   4 #include "lio.h"
   5 int L_len;
   6
   7 t_putc(c)
   8 {
   9         recpos++;
  10         putc(c,cf);
  11         return(0);
  12 }
  13 lwrt_I(n) ftnint n;
  14 {
  15         char buf[LINTW],*p;
  16 #ifdef USE_STRLEN
  17         (void) sprintf(buf," %ld",(long)n);
  18         if(recpos+strlen(buf)>=L_len)
  19 #else
  20         if(recpos + sprintf(buf," %ld",(long)n) >= L_len)
  21 #endif
  22                 (*donewrec)();
  23         for(p=buf;*p;PUT(*p++));
  24 }
  25 lwrt_L(n, len) ftnint n; ftnlen len;
  26 {
  27         if(recpos+LLOGW>=L_len)
  28                 (*donewrec)();
  29         (void) wrt_L((uint *)&n,LLOGW, len);
  30 }
  31 lwrt_A(p,len) char *p; ftnlen len;
  32 {
  33         int i;
  34         if(recpos+len>=L_len)
  35                 (*donewrec)();
  36         if (!recpos)
  37                 { PUT(' '); ++recpos; }
  38         for(i=0;i<len;i++) PUT(*p++);
  39 }
  40
  41  static int
  42 l_g(buf, absn) char *buf; double absn;
  43 {
  44         doublereal n;
  45         char *fmt;
  46
  47         n = absn;
  48         if (absn < 0)
  49                 absn = -absn;
  50         fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
  51 #ifdef USE_STRLEN
  52         sprintf(buf, fmt, n);
  53         return strlen(buf);
  54 #else
  55         return sprintf(buf, fmt, n);
  56 #endif
  57         }
  58
  59  static void
  60 l_put(s) register char *s;
  61 {
  62         register int c, (*pn)() = putn;
  63         while(c = *s++)
  64                 (*pn)(c);
  65         }
  66
  67 lwrt_F(n) double n;
  68 {
  69         char buf[LEFBL];
  70
  71         if(recpos + l_g(buf,n) >= L_len)
  72                 (*donewrec)();
  73         l_put(buf);
  74 }
  75 lwrt_C(a,b) double a,b;
  76 {
  77         char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
  78         int al, bl;
  79
  80         al = l_g(bufa, a);
  81         for(ba = bufa; *ba == ' '; ba++)
  82                 --al;
  83         bl = l_g(bufb, b) + 1;  /* intentionally high by 1 */
  84         for(bb = bufb; *bb == ' '; bb++)
  85                 --bl;
  86         if(recpos + al + bl + 3 >= L_len && recpos)
  87                 (*donewrec)();
  88         PUT(' ');
  89         PUT('(');
  90         l_put(ba);
  91         PUT(',');
  92         if (recpos + bl >= L_len) {
  93                 (*donewrec)();
  94                 PUT(' ');
  95                 }
  96         l_put(bb);
  97         PUT(')');
  98 }
  99 l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
 100 {
 101 #define Ptr ((flex *)ptr)
 102         int i;
 103         ftnint x;
 104         double y,z;
 105         real *xx;
 106         doublereal *yy;
 107         for(i=0;i< *number; i++)
 108         {
 109                 switch((int)type)
 110                 {
 111                 default: fatal(204,"unknown type in lio");
 112                 case TYSHORT:
 113                         x=Ptr->flshort;
 114                         goto xint;
 115                 case TYLONG:
 116                         x=Ptr->flint;
 117                 xint:   lwrt_I(x);
 118                         break;
 119                 case TYREAL:
 120                         y=Ptr->flreal;
 121                         goto xfloat;
 122                 case TYDREAL:
 123                         y=Ptr->fldouble;
 124                 xfloat: lwrt_F(y);
 125                         break;
 126                 case TYCOMPLEX:
 127                         xx= &Ptr->flreal;
 128                         y = *xx++;
 129                         z = *xx;
 130                         goto xcomplex;
 131                 case TYDCOMPLEX:
 132                         yy = &Ptr->fldouble;
 133                         y= *yy++;
 134                         z = *yy;
 135                 xcomplex:
 136                         lwrt_C(y,z);
 137                         break;
 138                 case TYLOGICAL:
 139                         lwrt_L(Ptr->flint, len);
 140                         break;
 141                 case TYCHAR:
 142                         lwrt_A(ptr,len);
 143                         break;
 144                 }
 145                 ptr += len;
 146         }
 147         return(0);
 148 }