home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / octa21fs.zip / octave / f2c / libi77 / lwrite.c < prev    next >
C/C++ Source or Header  |  2000-01-15  |  4KB  |  251 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "lio.h"
  5. ftnint L_len;
  6.  
  7. #ifdef KR_headers
  8. t_putc(c)
  9. #else
  10. t_putc(int c)
  11. #endif
  12. {
  13.     f__recpos++;
  14.     putc(c,f__cf);
  15.     return(0);
  16. }
  17.  static VOID
  18. #ifdef KR_headers
  19. lwrt_I(n) long n;
  20. #else
  21. lwrt_I(long n)
  22. #endif
  23. {
  24.     char buf[LINTW],*p;
  25. #ifdef USE_STRLEN
  26.     (void) sprintf(buf," %ld",n);
  27.     if(f__recpos+strlen(buf)>=L_len)
  28. #else
  29.     if(f__recpos + sprintf(buf," %ld",n) >= L_len)
  30. #endif
  31.         (*f__donewrec)();
  32.     for(p=buf;*p;PUT(*p++));
  33. }
  34.  static VOID
  35. #ifdef KR_headers
  36. lwrt_L(n, len) ftnint n; ftnlen len;
  37. #else
  38. lwrt_L(ftnint n, ftnlen len)
  39. #endif
  40. {
  41.     if(f__recpos+LLOGW>=L_len)
  42.         (*f__donewrec)();
  43.     wrt_L((Uint *)&n,LLOGW, len);
  44. }
  45.  static VOID
  46. #ifdef KR_headers
  47. lwrt_A(p,len) char *p; ftnlen len;
  48. #else
  49. lwrt_A(char *p, ftnlen len)
  50. #endif
  51. {
  52.     int i;
  53.     if(f__recpos+len>=L_len)
  54.         (*f__donewrec)();
  55.     if (!f__recpos)
  56.         { PUT(' '); ++f__recpos; }
  57.     for(i=0;i<len;i++) PUT(*p++);
  58. }
  59.  
  60.  static int
  61. #ifdef KR_headers
  62. l_g(buf, n) char *buf; double n;
  63. #else
  64. l_g(char *buf, double n)
  65. #endif
  66. {
  67. #ifdef Old_list_output
  68.     doublereal absn;
  69.     char *fmt;
  70.  
  71.     absn = n;
  72.     if (absn < 0)
  73.         absn = -absn;
  74.     fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
  75. #ifdef USE_STRLEN
  76.     sprintf(buf, fmt, n);
  77.     return strlen(buf);
  78. #else
  79.     return sprintf(buf, fmt, n);
  80. #endif
  81.  
  82. #else
  83.     register char *b, c, c1;
  84.  
  85.     b = buf;
  86.     *b++ = ' ';
  87.     if (n < 0) {
  88.         *b++ = '-';
  89.         n = -n;
  90.         }
  91.     else
  92.         *b++ = ' ';
  93.     if (n == 0) {
  94.         *b++ = '0';
  95.         *b++ = '.';
  96.         *b = 0;
  97.         goto f__ret;
  98.         }
  99.     sprintf(b, LGFMT, n);
  100.     if (*b == '0') {
  101.         while(b[0] = b[1])
  102.             b++;
  103.         }
  104.     /* Fortran 77 insists on having a decimal point... */
  105.     else for(;; b++)
  106.         switch(*b) {
  107.             case 0:
  108.                 *b++ = '.';
  109.                 *b = 0;
  110.                 goto f__ret;
  111.             case '.':
  112.                 while(*++b);
  113.                 goto f__ret;
  114.             case 'E':
  115.                 for(c1 = '.', c = 'E';  *b = c1;
  116.                     c1 = c, c = *++b);
  117.                 goto f__ret;
  118.             }
  119.  f__ret:
  120.     return b - buf;
  121. #endif
  122.     }
  123.  
  124.  static VOID
  125. #ifdef KR_headers
  126. l_put(s) register char *s;
  127. #else
  128. l_put(register char *s)
  129. #endif
  130. {
  131. #ifdef KR_headers
  132.     register int c, (*pn)() = f__putn;
  133. #else
  134.     register int c, (*pn)(int) = f__putn;
  135. #endif
  136.     while(c = *s++)
  137.         (*pn)(c);
  138.     }
  139.  
  140.  static VOID
  141. #ifdef KR_headers
  142. lwrt_F(n) double n;
  143. #else
  144. lwrt_F(double n)
  145. #endif
  146. {
  147.     char buf[LEFBL];
  148.  
  149.     if(f__recpos + l_g(buf,n) >= L_len)
  150.         (*f__donewrec)();
  151.     l_put(buf);
  152. }
  153.  static VOID
  154. #ifdef KR_headers
  155. lwrt_C(a,b) double a,b;
  156. #else
  157. lwrt_C(double a, double b)
  158. #endif
  159. {
  160.     char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
  161.     int al, bl;
  162.  
  163.     al = l_g(bufa, a);
  164.     for(ba = bufa; *ba == ' '; ba++)
  165.         --al;
  166.     bl = l_g(bufb, b) + 1;    /* intentionally high by 1 */
  167.     for(bb = bufb; *bb == ' '; bb++)
  168.         --bl;
  169.     if(f__recpos + al + bl + 3 >= L_len && f__recpos)
  170.         (*f__donewrec)();
  171.     PUT(' ');
  172.     PUT('(');
  173.     l_put(ba);
  174.     PUT(',');
  175.     if (f__recpos + bl >= L_len) {
  176.         (*f__donewrec)();
  177.         PUT(' ');
  178.         }
  179.     l_put(bb);
  180.     PUT(')');
  181. }
  182. #ifdef KR_headers
  183. l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  184. #else
  185. l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
  186. #endif
  187. {
  188. #define Ptr ((flex *)ptr)
  189.     int i;
  190.     long x;
  191.     double y,z;
  192.     real *xx;
  193.     doublereal *yy;
  194.     for(i=0;i< *number; i++)
  195.     {
  196.         switch((int)type)
  197.         {
  198.         default: f__fatal(204,"unknown type in lio");
  199.         case TYINT1:
  200.             x = Ptr->flchar;
  201.             goto xint;
  202.         case TYSHORT:
  203.             x=Ptr->flshort;
  204.             goto xint;
  205. #ifdef TYQUAD
  206.         case TYQUAD:
  207.             x = Ptr->fllongint;
  208.             goto xint;
  209. #endif
  210.         case TYLONG:
  211.             x=Ptr->flint;
  212.         xint:    lwrt_I(x);
  213.             break;
  214.         case TYREAL:
  215.             y=Ptr->flreal;
  216.             goto xfloat;
  217.         case TYDREAL:
  218.             y=Ptr->fldouble;
  219.         xfloat: lwrt_F(y);
  220.             break;
  221.         case TYCOMPLEX:
  222.             xx= &Ptr->flreal;
  223.             y = *xx++;
  224.             z = *xx;
  225.             goto xcomplex;
  226.         case TYDCOMPLEX:
  227.             yy = &Ptr->fldouble;
  228.             y= *yy++;
  229.             z = *yy;
  230.         xcomplex:
  231.             lwrt_C(y,z);
  232.             break;
  233.         case TYLOGICAL1:
  234.             x = Ptr->flchar;
  235.             goto xlog;
  236.         case TYLOGICAL2:
  237.             x = Ptr->flshort;
  238.             goto xlog;
  239.         case TYLOGICAL:
  240.             x = Ptr->flint;
  241.         xlog:    lwrt_L(Ptr->flint, len);
  242.             break;
  243.         case TYCHAR:
  244.             lwrt_A(ptr,len);
  245.             break;
  246.         }
  247.         ptr += len;
  248.     }
  249.     return(0);
  250. }
  251.