276 lines
4.1 KiB
C
276 lines
4.1 KiB
C
#include "f2c.h"
|
|
#include "fio.h"
|
|
#include "fmt.h"
|
|
#include "lio.h"
|
|
|
|
ftnint L_len;
|
|
int f__Aquote;
|
|
|
|
static void
|
|
donewrec (void)
|
|
{
|
|
if (f__recpos)
|
|
(*f__donewrec) ();
|
|
}
|
|
|
|
static void
|
|
lwrt_I (longint n)
|
|
{
|
|
char *p;
|
|
int ndigit, sign;
|
|
|
|
p = f__icvt (n, &ndigit, &sign, 10);
|
|
if (f__recpos + ndigit >= L_len)
|
|
donewrec ();
|
|
PUT (' ');
|
|
if (sign)
|
|
PUT ('-');
|
|
while (*p)
|
|
PUT (*p++);
|
|
}
|
|
static void
|
|
lwrt_L (ftnint n, ftnlen len)
|
|
{
|
|
if (f__recpos + LLOGW >= L_len)
|
|
donewrec ();
|
|
wrt_L ((Uint *) & n, LLOGW, len);
|
|
}
|
|
static void
|
|
lwrt_A (char *p, ftnlen len)
|
|
{
|
|
int a;
|
|
char *p1, *pe;
|
|
|
|
a = 0;
|
|
pe = p + len;
|
|
if (f__Aquote)
|
|
{
|
|
a = 3;
|
|
if (len > 1 && p[len - 1] == ' ')
|
|
{
|
|
while (--len > 1 && p[len - 1] == ' ');
|
|
pe = p + len;
|
|
}
|
|
p1 = p;
|
|
while (p1 < pe)
|
|
if (*p1++ == '\'')
|
|
a++;
|
|
}
|
|
if (f__recpos + len + a >= L_len)
|
|
donewrec ();
|
|
if (a
|
|
#ifndef OMIT_BLANK_CC
|
|
|| !f__recpos
|
|
#endif
|
|
)
|
|
PUT (' ');
|
|
if (a)
|
|
{
|
|
PUT ('\'');
|
|
while (p < pe)
|
|
{
|
|
if (*p == '\'')
|
|
PUT ('\'');
|
|
PUT (*p++);
|
|
}
|
|
PUT ('\'');
|
|
}
|
|
else
|
|
while (p < pe)
|
|
PUT (*p++);
|
|
}
|
|
|
|
static int
|
|
l_g (char *buf, double n)
|
|
{
|
|
#ifdef Old_list_output
|
|
doublereal absn;
|
|
char *fmt;
|
|
|
|
absn = n;
|
|
if (absn < 0)
|
|
absn = -absn;
|
|
fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
|
|
#ifdef USE_STRLEN
|
|
sprintf (buf, fmt, n);
|
|
return strlen (buf);
|
|
#else
|
|
return sprintf (buf, fmt, n);
|
|
#endif
|
|
|
|
#else
|
|
register char *b, c, c1;
|
|
|
|
b = buf;
|
|
*b++ = ' ';
|
|
if (n < 0)
|
|
{
|
|
*b++ = '-';
|
|
n = -n;
|
|
}
|
|
else
|
|
*b++ = ' ';
|
|
if (n == 0)
|
|
{
|
|
*b++ = '0';
|
|
*b++ = '.';
|
|
*b = 0;
|
|
goto f__ret;
|
|
}
|
|
sprintf (b, LGFMT, n);
|
|
switch (*b)
|
|
{
|
|
#ifndef WANT_LEAD_0
|
|
case '0':
|
|
while (b[0] = b[1])
|
|
b++;
|
|
break;
|
|
#endif
|
|
case 'i':
|
|
case 'I':
|
|
/* Infinity */
|
|
case 'n':
|
|
case 'N':
|
|
/* NaN */
|
|
while (*++b);
|
|
break;
|
|
|
|
default:
|
|
/* Fortran 77 insists on having a decimal point... */
|
|
for (;; b++)
|
|
switch (*b)
|
|
{
|
|
case 0:
|
|
*b++ = '.';
|
|
*b = 0;
|
|
goto f__ret;
|
|
case '.':
|
|
while (*++b);
|
|
goto f__ret;
|
|
case 'E':
|
|
for (c1 = '.', c = 'E'; *b = c1; c1 = c, c = *++b);
|
|
goto f__ret;
|
|
}
|
|
}
|
|
f__ret:
|
|
return b - buf;
|
|
#endif
|
|
}
|
|
|
|
static void
|
|
l_put (register char *s)
|
|
{
|
|
register void (*pn) (int) = f__putn;
|
|
register int c;
|
|
|
|
while (c = *s++)
|
|
(*pn) (c);
|
|
}
|
|
|
|
static void
|
|
lwrt_F (double n)
|
|
{
|
|
char buf[LEFBL];
|
|
|
|
if (f__recpos + l_g (buf, n) >= L_len)
|
|
donewrec ();
|
|
l_put (buf);
|
|
}
|
|
static void
|
|
lwrt_C (double a, double b)
|
|
{
|
|
char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
|
|
int al, bl;
|
|
|
|
al = l_g (bufa, a);
|
|
for (ba = bufa; *ba == ' '; ba++)
|
|
--al;
|
|
bl = l_g (bufb, b) + 1; /* intentionally high by 1 */
|
|
for (bb = bufb; *bb == ' '; bb++)
|
|
--bl;
|
|
if (f__recpos + al + bl + 3 >= L_len)
|
|
donewrec ();
|
|
#ifdef OMIT_BLANK_CC
|
|
else
|
|
#endif
|
|
PUT (' ');
|
|
PUT ('(');
|
|
l_put (ba);
|
|
PUT (',');
|
|
if (f__recpos + bl >= L_len)
|
|
{
|
|
(*f__donewrec) ();
|
|
#ifndef OMIT_BLANK_CC
|
|
PUT (' ');
|
|
#endif
|
|
}
|
|
l_put (bb);
|
|
PUT (')');
|
|
}
|
|
l_write (ftnint * number, char *ptr, ftnlen len, ftnint type)
|
|
{
|
|
#define Ptr ((flex *)ptr)
|
|
int i;
|
|
longint x;
|
|
double y, z;
|
|
real *xx;
|
|
doublereal *yy;
|
|
for (i = 0; i < *number; i++)
|
|
{
|
|
switch ((int) type)
|
|
{
|
|
default:
|
|
f__fatal (204, "unknown type in lio");
|
|
case TYINT1:
|
|
x = Ptr->flchar;
|
|
goto xint;
|
|
case TYSHORT:
|
|
x = Ptr->flshort;
|
|
goto xint;
|
|
#ifdef Allow_TYQUAD
|
|
case TYQUAD:
|
|
x = Ptr->fllongint;
|
|
goto xint;
|
|
#endif
|
|
case TYLONG:
|
|
x = Ptr->flint;
|
|
xint:lwrt_I (x);
|
|
break;
|
|
case TYREAL:
|
|
y = Ptr->flreal;
|
|
goto xfloat;
|
|
case TYDREAL:
|
|
y = Ptr->fldouble;
|
|
xfloat:lwrt_F (y);
|
|
break;
|
|
case TYCOMPLEX:
|
|
xx = &Ptr->flreal;
|
|
y = *xx++;
|
|
z = *xx;
|
|
goto xcomplex;
|
|
case TYDCOMPLEX:
|
|
yy = &Ptr->fldouble;
|
|
y = *yy++;
|
|
z = *yy;
|
|
xcomplex:
|
|
lwrt_C (y, z);
|
|
break;
|
|
case TYLOGICAL1:
|
|
x = Ptr->flchar;
|
|
goto xlog;
|
|
case TYLOGICAL2:
|
|
x = Ptr->flshort;
|
|
goto xlog;
|
|
case TYLOGICAL:
|
|
x = Ptr->flint;
|
|
xlog:lwrt_L (Ptr->flint, len);
|
|
break;
|
|
case TYCHAR:
|
|
lwrt_A (ptr, len);
|
|
break;
|
|
}
|
|
ptr += len;
|
|
}
|
|
return (0);
|
|
}
|