home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / f2csrc.zip / f2csrc / libI77 / lwrite.c < prev    next >
C/C++ Source or Header  |  1994-07-28  |  4KB  |  270 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. #ifndef OMIT_BLANK_CC
  56.     if (!f__recpos)
  57.         PUT(' ');
  58. #endif
  59.     for(i=0;i<len;i++) PUT(*p++);
  60. }
  61.  
  62.  static int
  63. #ifdef KR_headers
  64. l_g(buf, n) char *buf; double n;
  65. #else
  66. l_g(char *buf, double n)
  67. #endif
  68. {
  69. #ifdef Old_list_output
  70.     doublereal absn;
  71.     char *fmt;
  72.  
  73.     absn = n;
  74.     if (absn < 0)
  75.         absn = -absn;
  76.     fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
  77. #ifdef USE_STRLEN
  78.     sprintf(buf, fmt, n);
  79.     return strlen(buf);
  80. #else
  81.     return sprintf(buf, fmt, n);
  82. #endif
  83.  
  84. #else
  85.     register char *b, c, c1;
  86.  
  87.     b = buf;
  88.     *b++ = ' ';
  89.     if (n < 0) {
  90.         *b++ = '-';
  91.         n = -n;
  92.         }
  93.     else
  94.         *b++ = ' ';
  95.     if (n == 0) {
  96.         *b++ = '0';
  97.         *b++ = '.';
  98.         *b = 0;
  99.         goto f__ret;
  100.         }
  101.     sprintf(b, LGFMT, n);
  102.     switch(*b) {
  103.         case '0':
  104.             while(b[0] = b[1])
  105.                 b++;
  106.             break;
  107.         case 'i':
  108.         case 'I':
  109.             /* Infinity */
  110.         case 'n':
  111.         case 'N':
  112.             /* NaN */
  113.             while(*++b);
  114.             break;
  115.  
  116.         default:
  117.     /* Fortran 77 insists on having a decimal point... */
  118.             for(;; b++)
  119.             switch(*b) {
  120.             case 0:
  121.                 *b++ = '.';
  122.                 *b = 0;
  123.                 goto f__ret;
  124.             case '.':
  125.                 while(*++b);
  126.                 goto f__ret;
  127.             case 'E':
  128.                 for(c1 = '.', c = 'E';  *b = c1;
  129.                     c1 = c, c = *++b);
  130.                 goto f__ret;
  131.             }
  132.         }
  133.  f__ret:
  134.     return b - buf;
  135. #endif
  136.     }
  137.  
  138.  static VOID
  139. #ifdef KR_headers
  140. l_put(s) register char *s;
  141. #else
  142. l_put(register char *s)
  143. #endif
  144. {
  145. #ifdef KR_headers
  146.     register int c, (*pn)() = f__putn;
  147. #else
  148.     register int c, (*pn)(int) = f__putn;
  149. #endif
  150.     while(c = *s++)
  151.         (*pn)(c);
  152.     }
  153.  
  154.  static VOID
  155. #ifdef KR_headers
  156. lwrt_F(n) double n;
  157. #else
  158. lwrt_F(double n)
  159. #endif
  160. {
  161.     char buf[LEFBL];
  162.  
  163.     if(f__recpos + l_g(buf,n) >= L_len)
  164.         (*f__donewrec)();
  165.     l_put(buf);
  166. }
  167.  static VOID
  168. #ifdef KR_headers
  169. lwrt_C(a,b) double a,b;
  170. #else
  171. lwrt_C(double a, double b)
  172. #endif
  173. {
  174.     char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
  175.     int al, bl;
  176.  
  177.     al = l_g(bufa, a);
  178.     for(ba = bufa; *ba == ' '; ba++)
  179.         --al;
  180.     bl = l_g(bufb, b) + 1;    /* intentionally high by 1 */
  181.     for(bb = bufb; *bb == ' '; bb++)
  182.         --bl;
  183.     if(f__recpos + al + bl + 3 >= L_len && f__recpos)
  184.         (*f__donewrec)();
  185. #ifdef OMIT_BLANK_CC
  186.     else
  187. #endif
  188.     PUT(' ');
  189.     PUT('(');
  190.     l_put(ba);
  191.     PUT(',');
  192.     if (f__recpos + bl >= L_len) {
  193.         (*f__donewrec)();
  194. #ifndef OMIT_BLANK_CC
  195.         PUT(' ');
  196. #endif
  197.         }
  198.     l_put(bb);
  199.     PUT(')');
  200. }
  201. #ifdef KR_headers
  202. l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  203. #else
  204. l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
  205. #endif
  206. {
  207. #define Ptr ((flex *)ptr)
  208.     int i;
  209.     long x;
  210.     double y,z;
  211.     real *xx;
  212.     doublereal *yy;
  213.     for(i=0;i< *number; i++)
  214.     {
  215.         switch((int)type)
  216.         {
  217.         default: f__fatal(204,"unknown type in lio");
  218.         case TYINT1:
  219.             x = Ptr->flchar;
  220.             goto xint;
  221.         case TYSHORT:
  222.             x=Ptr->flshort;
  223.             goto xint;
  224. #ifdef TYQUAD
  225.         case TYQUAD:
  226.             x = Ptr->fllongint;
  227.             goto xint;
  228. #endif
  229.         case TYLONG:
  230.             x=Ptr->flint;
  231.         xint:    lwrt_I(x);
  232.             break;
  233.         case TYREAL:
  234.             y=Ptr->flreal;
  235.             goto xfloat;
  236.         case TYDREAL:
  237.             y=Ptr->fldouble;
  238.         xfloat: lwrt_F(y);
  239.             break;
  240.         case TYCOMPLEX:
  241.             xx= &Ptr->flreal;
  242.             y = *xx++;
  243.             z = *xx;
  244.             goto xcomplex;
  245.         case TYDCOMPLEX:
  246.             yy = &Ptr->fldouble;
  247.             y= *yy++;
  248.             z = *yy;
  249.         xcomplex:
  250.             lwrt_C(y,z);
  251.             break;
  252.         case TYLOGICAL1:
  253.             x = Ptr->flchar;
  254.             goto xlog;
  255.         case TYLOGICAL2:
  256.             x = Ptr->flshort;
  257.             goto xlog;
  258.         case TYLOGICAL:
  259.             x = Ptr->flint;
  260.         xlog:    lwrt_L(Ptr->flint, len);
  261.             break;
  262.         case TYCHAR:
  263.             lwrt_A(ptr,len);
  264.             break;
  265.         }
  266.         ptr += len;
  267.     }
  268.     return(0);
  269. }
  270.