--- /dev/null
+LIST
+Notice
+README
+Version.c
+abort_.c
+c_abs.c
+c_cos.c
+c_div.c
+c_exp.c
+c_log.c
+c_sin.c
+c_sqrt.c
+cabs.c
+d_abs.c
+d_acos.c
+d_asin.c
+d_atan.c
+d_atn2.c
+d_cnjg.c
+d_cos.c
+d_cosh.c
+d_dim.c
+d_exp.c
+d_imag.c
+d_int.c
+d_lg10.c
+d_log.c
+d_mod.c
+d_nint.c
+d_prod.c
+d_sign.c
+d_sin.c
+d_sinh.c
+d_sqrt.c
+d_tan.c
+d_tanh.c
+derf_.c
+derfc_.c
+ef1asc_.c
+ef1cmc_.c
+erf_.c
+erfc_.c
+getarg_.c
+getenv_.c
+h_abs.c
+h_dim.c
+h_dnnt.c
+h_indx.c
+h_len.c
+h_mod.c
+h_nint.c
+h_sign.c
+hl_ge.c
+hl_gt.c
+hl_le.c
+hl_lt.c
+i_abs.c
+i_dim.c
+i_dnnt.c
+i_indx.c
+i_len.c
+i_mod.c
+i_nint.c
+i_sign.c
+iargc_.c
+l_ge.c
+l_gt.c
+l_le.c
+l_lt.c
+libF77.xsum
+main.c
+makefile
+pow_ci.c
+pow_dd.c
+pow_di.c
+pow_hh.c
+pow_ii.c
+pow_ri.c
+pow_zi.c
+pow_zz.c
+r_abs.c
+r_acos.c
+r_asin.c
+r_atan.c
+r_atn2.c
+r_cnjg.c
+r_cos.c
+r_cosh.c
+r_dim.c
+r_exp.c
+r_imag.c
+r_int.c
+r_lg10.c
+r_log.c
+r_mod.c
+r_nint.c
+r_sign.c
+r_sin.c
+r_sinh.c
+r_sqrt.c
+r_tan.c
+r_tanh.c
+s_cat.c
+s_cmp.c
+s_copy.c
+s_paus.c
+s_rnge.c
+s_stop.c
+sig_die.c
+signal_.c
+system_.c
+z_abs.c
+z_cos.c
+z_div.c
+z_exp.c
+z_log.c
+z_sin.c
+z_sqrt.c
--- /dev/null
+Version.c
+abort_.c
+c_abs.c
+c_cos.c
+c_div.c
+c_exp.c
+c_log.c
+c_sin.c
+c_sqrt.c
+cabs.c
+d_abs.c
+d_acos.c
+d_asin.c
+d_atan.c
+d_atn2.c
+d_cnjg.c
+d_cos.c
+d_cosh.c
+d_dim.c
+d_exp.c
+d_imag.c
+d_int.c
+d_lg10.c
+d_log.c
+d_mod.c
+d_nint.c
+d_prod.c
+d_sign.c
+d_sin.c
+d_sinh.c
+d_sqrt.c
+d_tan.c
+d_tanh.c
+derf_.c
+derfc_.c
+ef1asc_.c
+ef1cmc_.c
+erf_.c
+erfc_.c
+getarg_.c
+getenv_.c
+h_abs.c
+h_dim.c
+h_dnnt.c
+h_indx.c
+h_len.c
+h_mod.c
+h_nint.c
+h_sign.c
+hl_ge.c
+hl_gt.c
+hl_le.c
+hl_lt.c
+i_abs.c
+i_dim.c
+i_dnnt.c
+i_indx.c
+i_len.c
+i_mod.c
+i_nint.c
+i_sign.c
+iargc_.c
+l_ge.c
+l_gt.c
+l_le.c
+l_lt.c
+main.c
+pow_ci.c
+pow_dd.c
+pow_di.c
+pow_hh.c
+pow_ii.c
+pow_ri.c
+pow_zi.c
+pow_zz.c
+r_abs.c
+r_acos.c
+r_asin.c
+r_atan.c
+r_atn2.c
+r_cnjg.c
+r_cos.c
+r_cosh.c
+r_dim.c
+r_exp.c
+r_imag.c
+r_int.c
+r_lg10.c
+r_log.c
+r_mod.c
+r_nint.c
+r_sign.c
+r_sin.c
+r_sinh.c
+r_sqrt.c
+r_tan.c
+r_tanh.c
+s_cat.c
+s_cmp.c
+s_copy.c
+s_paus.c
+s_rnge.c
+s_stop.c
+sig_die.c
+signal_.c
+system_.c
+z_abs.c
+z_cos.c
+z_div.c
+z_exp.c
+z_log.c
+z_sin.c
+z_sqrt.c
--- /dev/null
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
--- /dev/null
+If your system lacks onexit() and you are not using an ANSI C
+compiler, then you should compile main.c with NO_ONEXIT defined.
+See the comments about onexit in the makefile.
+
+If your system has a double drem() function such that drem(a,b)
+is the IEEE remainder function (with double a, b), then you may
+wish to compile r_mod.c and d_mod.c with IEEE_drem defined.
+
+To check for transmission errors, issue the command
+ make check
+This assumes you have the xsum program whose source, xsum.c,
+is distributed as part of "all from f2c/src". If you do not
+have xsum, you can obtain xsum.c by sending the following E-mail
+message to netlib@research.att.com
+ send xsum.c from f2c/src
+
+The makefile assumes you have installed f2c.h in a standard
+place (and does not cause recompilation when f2c.h is changed);
+f2c.h comes with "all from f2c" (the source for f2c) and is
+available separately ("f2c.h from f2c").
--- /dev/null
+static char junk[] = "\n@(#)LIBF77 VERSION 2.01 31 May 1991\n";
+
+/*
+2.00 11 June 1980. File version.c added to library.
+2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed
+ [ d]erf[c ] added
+ 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c
+ 29 Nov. 1989: s_cmp returns long (for f2c)
+ 30 Nov. 1989: arg types from f2c.h
+ 12 Dec. 1989: s_rnge allows long names
+ 19 Dec. 1989: getenv_ allows unsorted environment
+ 28 Mar. 1990: add exit(0) to end of main()
+ 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main
+ 17 Oct. 1990: abort() calls changed to sig_die(...,1)
+ 22 Oct. 1990: separate sig_die from main
+ 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die
+ 31 May 1991: make system_ return status
+*/
--- /dev/null
+#include "stdio.h"
+#include "f2c.h"
+
+extern VOID sig_die();
+
+VOID abort_()
+{
+sig_die("Fortran abort routine called", 1);
+}
--- /dev/null
+#include "f2c.h"
+
+double c_abs(z)
+complex *z;
+{
+double cabs();
+
+return( cabs( z->r, z->i ) );
+}
--- /dev/null
+#include "f2c.h"
+
+VOID c_cos(r, z)
+complex *r, *z;
+{
+double sin(), cos(), sinh(), cosh();
+
+r->r = cos(z->r) * cosh(z->i);
+r->i = - sin(z->r) * sinh(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+extern VOID sig_die();
+
+VOID c_div(c, a, b)
+complex *a, *b, *c;
+{
+double ratio, den;
+double abr, abi;
+
+if( (abr = b->r) < 0.)
+ abr = - abr;
+if( (abi = b->i) < 0.)
+ abi = - abi;
+if( abr <= abi )
+ {
+ if(abi == 0)
+ sig_die("complex division by zero", 1);
+ ratio = (double)b->r / b->i ;
+ den = b->i * (1 + ratio*ratio);
+ c->r = (a->r*ratio + a->i) / den;
+ c->i = (a->i*ratio - a->r) / den;
+ }
+
+else
+ {
+ ratio = (double)b->i / b->r ;
+ den = b->r * (1 + ratio*ratio);
+ c->r = (a->r + a->i*ratio) / den;
+ c->i = (a->i - a->r*ratio) / den;
+ }
+}
--- /dev/null
+#include "f2c.h"
+
+VOID c_exp(r, z)
+complex *r, *z;
+{
+double expx;
+double exp(), cos(), sin();
+
+expx = exp(z->r);
+r->r = expx * cos(z->i);
+r->i = expx * sin(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+VOID c_log(r, z)
+complex *r, *z;
+{
+double log(), cabs(), atan2();
+
+r->i = atan2(z->i, z->r);
+r->r = log( cabs(z->r, z->i) );
+}
--- /dev/null
+#include "f2c.h"
+
+VOID c_sin(r, z)
+complex *r, *z;
+{
+double sin(), cos(), sinh(), cosh();
+
+r->r = sin(z->r) * cosh(z->i);
+r->i = cos(z->r) * sinh(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+VOID c_sqrt(r, z)
+complex *r, *z;
+{
+double mag, t, sqrt(), cabs();
+
+if( (mag = cabs(z->r, z->i)) == 0.)
+ r->r = r->i = 0.;
+else if(z->r > 0)
+ {
+ r->r = t = sqrt(0.5 * (mag + z->r) );
+ t = z->i / t;
+ r->i = 0.5 * t;
+ }
+else
+ {
+ t = sqrt(0.5 * (mag - z->r) );
+ if(z->i < 0)
+ t = -t;
+ r->i = t;
+ t = z->i / t;
+ r->r = 0.5 * t;
+ }
+}
--- /dev/null
+double cabs(real, imag)
+double real, imag;
+{
+double temp, sqrt();
+
+if(real < 0)
+ real = -real;
+if(imag < 0)
+ imag = -imag;
+if(imag > real){
+ temp = real;
+ real = imag;
+ imag = temp;
+}
+if((real+imag) == real)
+ return(real);
+
+temp = imag/real;
+temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/
+return(temp);
+}
--- /dev/null
+#include "f2c.h"
+
+double d_abs(x)
+doublereal *x;
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
--- /dev/null
+#include "f2c.h"
+
+double d_acos(x)
+doublereal *x;
+{
+double acos();
+return( acos(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_asin(x)
+doublereal *x;
+{
+double asin();
+return( asin(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_atan(x)
+doublereal *x;
+{
+double atan();
+return( atan(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_atn2(x,y)
+doublereal *x, *y;
+{
+double atan2();
+return( atan2(*x,*y) );
+}
--- /dev/null
+#include "f2c.h"
+
+d_cnjg(r, z)
+doublecomplex *r, *z;
+{
+r->r = z->r;
+r->i = - z->i;
+}
--- /dev/null
+#include "f2c.h"
+
+double d_cos(x)
+doublereal *x;
+{
+double cos();
+return( cos(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_cosh(x)
+doublereal *x;
+{
+double cosh();
+return( cosh(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_dim(a,b)
+doublereal *a, *b;
+{
+return( *a > *b ? *a - *b : 0);
+}
--- /dev/null
+#include "f2c.h"
+
+double d_exp(x)
+doublereal *x;
+{
+double exp();
+return( exp(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_imag(z)
+doublecomplex *z;
+{
+return(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+double d_int(x)
+doublereal *x;
+{
+double floor();
+
+return( (*x>0) ? floor(*x) : -floor(- *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+#define log10e 0.43429448190325182765
+
+double d_lg10(x)
+doublereal *x;
+{
+double log();
+
+return( log10e * log(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_log(x)
+doublereal *x;
+{
+double log();
+return( log(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_mod(x,y)
+doublereal *x, *y;
+{
+#ifdef IEEE_drem
+ double drem(), xa, ya, z;
+ if ((ya = *y) < 0.)
+ ya = -ya;
+ z = drem(xa = *x, ya);
+ if (xa > 0) {
+ if (z < 0)
+ z += ya;
+ }
+ else if (z > 0)
+ z -= ya;
+ return z;
+#else
+ double floor(), quotient;
+ if( (quotient = *x / *y) >= 0)
+ quotient = floor(quotient);
+ else
+ quotient = -floor(-quotient);
+ return(*x - (*y) * quotient );
+#endif
+}
--- /dev/null
+#include "f2c.h"
+
+double d_nint(x)
+doublereal *x;
+{
+double floor();
+
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_prod(x,y)
+real *x, *y;
+{
+return( (*x) * (*y) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_sign(a,b)
+doublereal *a, *b;
+{
+double x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
--- /dev/null
+#include "f2c.h"
+
+double d_sin(x)
+doublereal *x;
+{
+double sin();
+return( sin(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_sinh(x)
+doublereal *x;
+{
+double sinh();
+return( sinh(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_sqrt(x)
+doublereal *x;
+{
+double sqrt();
+return( sqrt(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_tan(x)
+doublereal *x;
+{
+double tan();
+return( tan(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double d_tanh(x)
+doublereal *x;
+{
+double tanh();
+return( tanh(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double derf_(x)
+doublereal *x;
+{
+double erf();
+
+return( erf(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double derfc_(x)
+doublereal *x;
+{
+double erfc();
+
+return( erfc(*x) );
+}
--- /dev/null
+/* EFL support routine to copy string b to string a */
+
+#include "f2c.h"
+
+extern VOID s_copy();
+
+#define M ( (long) (sizeof(long) - 1) )
+#define EVEN(x) ( ( (x)+ M) & (~M) )
+
+VOID ef1asc_(a, la, b, lb)
+int *a, *b;
+long int *la, *lb;
+{
+s_copy( (char *)a, (char *)b, EVEN(*la), *lb );
+}
--- /dev/null
+/* EFL support routine to compare two character strings */
+
+#include "f2c.h"
+
+extern integer s_cmp();
+
+integer ef1cmc_(a, la, b, lb)
+integer *a, *b;
+integer *la, *lb;
+{
+return( s_cmp( (char *)a, (char *)b, *la, *lb) );
+}
--- /dev/null
+#include "f2c.h"
+
+double erf_(x)
+real *x;
+{
+double erf();
+
+return( erf(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double erfc_(x)
+real *x;
+{
+double erfc();
+
+return( erfc(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+/*
+ * subroutine getarg(k, c)
+ * returns the kth unix command argument in fortran character
+ * variable argument c
+*/
+
+VOID getarg_(n, s, ls)
+long int *n;
+register char *s;
+long int ls;
+{
+extern int xargc;
+extern char **xargv;
+register char *t;
+register int i;
+
+if(*n>=0 && *n<xargc)
+ t = xargv[*n];
+else
+ t = "";
+for(i = 0; i<ls && *t!='\0' ; ++i)
+ *s++ = *t++;
+for( ; i<ls ; ++i)
+ *s++ = ' ';
+}
--- /dev/null
+#include "f2c.h"
+
+/*
+ * getenv - f77 subroutine to return environment variables
+ *
+ * called by:
+ * call getenv (ENV_NAME, char_var)
+ * where:
+ * ENV_NAME is the name of an environment variable
+ * char_var is a character variable which will receive
+ * the current value of ENV_NAME, or all blanks
+ * if ENV_NAME is not defined
+ */
+
+VOID getenv_(fname, value, flen, vlen)
+char *value, *fname;
+long int vlen, flen;
+{
+extern char **environ;
+register char *ep, *fp, *flast;
+register char **env = environ;
+
+flast = fname + flen;
+for(fp = fname ; fp < flast ; ++fp)
+ if(*fp == ' ')
+ {
+ flast = fp;
+ break;
+ }
+
+while (ep = *env++)
+ {
+ for(fp = fname; fp<flast ; )
+ if(*fp++ != *ep++)
+ goto endloop;
+
+ if(*ep++ == '=') { /* copy right hand side */
+ while( *ep && --vlen>=0 )
+ *value++ = *ep++;
+
+ goto blank;
+ }
+endloop: ;
+ }
+
+blank:
+ while( --vlen >= 0 )
+ *value++ = ' ';
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_abs(x)
+shortint *x;
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_dim(a,b)
+shortint *a, *b;
+{
+return( *a > *b ? *a - *b : 0);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_dnnt(x)
+doublereal *x;
+{
+double floor();
+
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_indx(a, b, la, lb)
+char *a, *b;
+long int la, lb;
+{
+int i, n;
+char *s, *t, *bend;
+
+n = la - lb + 1;
+bend = b + lb;
+
+for(i = 0 ; i < n ; ++i)
+ {
+ s = a + i;
+ t = b;
+ while(t < bend)
+ if(*s++ != *t++)
+ goto no;
+ return(i+1);
+ no: ;
+ }
+return(0);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_len(s, n)
+char *s;
+long int n;
+{
+return(n);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_mod(a,b)
+short *a, *b;
+{
+return( *a % *b);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_nint(x)
+real *x;
+{
+double floor();
+
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint h_sign(a,b)
+shortint *a, *b;
+{
+shortint x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint hl_ge(a,b,la,lb)
+char *a, *b;
+long int la, lb;
+{
+return(s_cmp(a,b,la,lb) >= 0);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint hl_gt(a,b,la,lb)
+char *a, *b;
+long int la, lb;
+{
+return(s_cmp(a,b,la,lb) > 0);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint hl_le(a,b,la,lb)
+char *a, *b;
+long int la, lb;
+{
+return(s_cmp(a,b,la,lb) <= 0);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+shortint hl_lt(a,b,la,lb)
+char *a, *b;
+long int la, lb;
+{
+return(s_cmp(a,b,la,lb) < 0);
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_abs(x)
+integer *x;
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_dim(a,b)
+integer *a, *b;
+{
+return( *a > *b ? *a - *b : 0);
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_dnnt(x)
+doublereal *x;
+{
+double floor();
+
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_indx(a, b, la, lb)
+char *a, *b;
+long int la, lb;
+{
+long int i, n;
+char *s, *t, *bend;
+
+n = la - lb + 1;
+bend = b + lb;
+
+for(i = 0 ; i < n ; ++i)
+ {
+ s = a + i;
+ t = b;
+ while(t < bend)
+ if(*s++ != *t++)
+ goto no;
+ return(i+1);
+ no: ;
+ }
+return(0);
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_len(s, n)
+char *s;
+long int n;
+{
+return(n);
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_mod(a,b)
+integer *a, *b;
+{
+return( *a % *b);
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_nint(x)
+real *x;
+{
+double floor();
+
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+integer i_sign(a,b)
+integer *a, *b;
+{
+integer x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
--- /dev/null
+#include "f2c.h"
+
+integer iargc_()
+{
+extern int xargc;
+return ( xargc - 1 );
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+integer l_ge(a,b,la,lb)
+char *a, *b;
+long int la, lb;
+{
+return(s_cmp(a,b,la,lb) >= 0);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+integer l_gt(a,b,la,lb)
+char *a, *b;
+long int la, lb;
+{
+return(s_cmp(a,b,la,lb) > 0);
+}
--- /dev/null
+#include "f2c.h"
+
+extern integer s_cmp();
+
+integer l_le(a,b,la,lb)
+char *a, *b;
+long int la, lb;
+{
+return(s_cmp(a,b,la,lb) <= 0);
+}
--- /dev/null
+#include "f2c.h"
+
+integer l_lt(a,b,la,lb)
+char *a, *b;
+long la, lb;
+{
+return(s_cmp(a,b,la,lb) < 0);
+}
--- /dev/null
+Notice fb5a412e 1183
+README 129e17de 902
+Version.c f4072818 752
+abort_.c 1ddc061a 123
+c_abs.c 3ccfc99 96
+c_cos.c 1d2a43cc 157
+c_div.c f08f5e0a 556
+c_exp.c f26ec4d4 165
+c_log.c ea713636 145
+c_sin.c eedb2a9 155
+c_sqrt.c e863dae 348
+cabs.c 514923b 309
+d_abs.c 8525b15 92
+d_acos.c e4d05af5 89
+d_asin.c f0d01384 89
+d_atan.c 1110dced 89
+d_atn2.c e098ae4 100
+d_cnjg.c e3e9622f 85
+d_cos.c ed9f8b7c 86
+d_cosh.c 19d05b3e 89
+d_dim.c e458c4ea 91
+d_exp.c ef428642 86
+d_imag.c c057bf1 71
+d_int.c 1e86e392 115
+d_lg10.c a976032 136
+d_log.c 4d50239 86
+d_mod.c ea39a739 415
+d_nint.c fcbb75a8 126
+d_prod.c 1a6760da 77
+d_sign.c f80806fe 124
+d_sin.c 4d62b63 86
+d_sinh.c e0c61add 89
+d_sqrt.c ec746103 89
+d_tan.c e19875b1 86
+d_tanh.c 1a4903ee 89
+derf_.c f82e7a98 87
+derfc_.c 17681562 90
+ef1asc_.c 10a294bd 285
+ef1cmc_.c e2000a1f 221
+erf_.c e51d2afe 80
+erfc_.c 1eeada84 83
+getarg_.c f7e5a7e2 415
+getenv_.c f2fbc977 881
+h_abs.c f17a9d28 117
+h_dim.c efa53d0c 116
+h_dnnt.c 1b6e30b4 153
+h_indx.c e541126 302
+h_len.c e5f0ba39 100
+h_mod.c e5070b30 99
+h_nint.c f2f6a9b6 147
+h_sign.c e0424bd3 151
+hl_ge.c f34d97c0 134
+hl_gt.c 1e9364c1 133
+hl_le.c 68dbb84 134
+hl_lt.c 3f5ec5a 133
+i_abs.c e9df85da 90
+i_dim.c f93e306f 89
+i_dnnt.c 1c51efb 127
+i_indx.c b222d76 281
+i_len.c 17926ad5 74
+i_mod.c 6b15148 75
+i_nint.c f3e91f29 121
+i_sign.c e8e073b2 123
+iargc_.c fd9410d9 79
+l_ge.c 1adab0fd 132
+l_gt.c e9f5bde3 131
+l_le.c ef1a9cb9 132
+l_lt.c fb4a7a8c 102
+main.c ef83b695 1362
+makefile ef8a327a 2943
+pow_ci.c 62b6caf 186
+pow_dd.c e1caeeb1 104
+pow_di.c ec10f0b0 325
+pow_hh.c e4161aa7 245
+pow_ii.c d0fbe46 242
+pow_ri.c fbdbece8 319
+pow_zi.c e87e82cc 518
+pow_zz.c fde95b82 312
+r_abs.c 1b85bc 86
+r_acos.c 11eeee20 83
+r_asin.c e7b27881 83
+r_atan.c 8920297 83
+r_atn2.c 4ac36c3 94
+r_cnjg.c e5db6724 84
+r_cos.c e07cb241 80
+r_cosh.c f51deb04 83
+r_dim.c 10a3ddd9 85
+r_exp.c 13e47ded 80
+r_imag.c 1703a645 65
+r_int.c c849cbb 109
+r_lg10.c 187b31e7 130
+r_log.c e5240928 80
+r_mod.c 7894f0d 417
+r_nint.c ff0c2044 120
+r_sign.c fc88b617 118
+r_sin.c 14626334 80
+r_sinh.c ea3a24ec 83
+r_sqrt.c e685c7f1 83
+r_tan.c ff2454a8 80
+r_tanh.c fa01b1c7 83
+s_cat.c 60770ce 294
+s_cmp.c 1aceca99 507
+s_copy.c 1783e78d 279
+s_paus.c f398b5e3 746
+s_rnge.c 7eaeb87 513
+s_stop.c f1f95e02 238
+sig_die.c f0fbd1a3 391
+signal_.c 1fd402d7 234
+system_.c 5d071f1 287
+z_abs.c f33e298 102
+z_cos.c 281d763 163
+z_div.c 8b4794a 547
+z_exp.c 1e060b77 171
+z_log.c f92a692d 153
+z_sin.c 8cb5ee6 161
+z_sqrt.c f0e4dfde 332
--- /dev/null
+/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */
+
+#include "stdio.h"
+#include "signal.h"
+
+#ifndef SIGIOT
+#define SIGIOT SIGABRT
+#endif
+
+#ifdef NO__STDC
+#define ONEXIT onexit
+extern void f_exit();
+#else
+#ifdef __STDC__
+#include "stdlib.h"
+extern void f_exit(void);
+#ifndef NO_ONEXIT
+#define ONEXIT atexit
+extern int atexit(void (*)(void));
+#endif
+#else
+#ifndef NO_ONEXIT
+#define ONEXIT onexit
+extern void f_exit();
+#endif
+#endif
+#endif
+
+extern void sig_die();
+
+static void sigfdie(n)
+{
+sig_die("Floating Exception", 1);
+}
+
+
+static void sigidie(n)
+{
+sig_die("IOT Trap", 1);
+}
+
+#ifdef SIGQUIT
+static void sigqdie(n)
+{
+sig_die("Quit signal", 1);
+}
+#endif
+
+
+static void sigindie(n)
+{
+sig_die("Interrupt", 0);
+}
+
+
+
+static void sigtdie(n)
+{
+sig_die("Killed", 0);
+}
+
+
+int xargc;
+char **xargv;
+
+main(argc, argv)
+int argc;
+char **argv;
+{
+xargc = argc;
+xargv = argv;
+signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
+signal(SIGIOT, sigidie);
+#ifdef SIGQUIT
+if(signal(SIGQUIT,sigqdie) == SIG_IGN)
+ signal(SIGQUIT, SIG_IGN);
+#endif
+if(signal(SIGINT, sigindie) == SIG_IGN)
+ signal(SIGINT, SIG_IGN);
+signal(SIGTERM,sigtdie);
+
+#ifdef pdp11
+ ldfps(01200); /* detect overflow as an exception */
+#endif
+
+f_init();
+#ifndef NO_ONEXIT
+ONEXIT(f_exit);
+#endif
+MAIN__();
+#ifdef NO_ONEXIT
+f_exit();
+#endif
+exit(0); /* exit(0) rather than return(0) to bypass Cray bug */
+}
--- /dev/null
+.SUFFIXES: .c .o
+CC = cc
+SHELL = /bin/sh
+
+# compile, then strip unnecessary symbols
+.c.o:
+ $(CC) -O -c -DSkip_f2c_Undefs $*.c
+ ld -r -x $*.o
+ mv a.out $*.o
+
+MISC = Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o getenv_.o\
+ signal_.o s_stop.o s_paus.o system_.o cabs.o\
+ derf_.o derfc_.o erf_.o erfc_.o sig_die.o
+POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o
+CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
+DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
+REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
+ r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
+ r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
+ r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
+DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
+ d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
+ d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
+ d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
+ d_sqrt.o d_tan.o d_tanh.o
+INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o
+HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o
+CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o
+EFL = ef1asc_.o ef1cmc_.o
+CHAR = s_cat.o s_cmp.o s_copy.o
+
+libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
+ $(HALF) $(CMP) $(EFL) $(CHAR)
+ ar r libF77.a $?
+ ranlib libF77.a
+
+Version.o: Version.c
+ $(CC) -c Version.c
+
+# If your system lacks onexit() and you are not using an
+# ANSI C compiler, then you should uncomment the following
+# two lines (for compiling main.o):
+#main.o: main.c
+# $(CC) -c -DNO_ONEXIT -DSkip_f2c_Undefs main.c
+# On at least some Sun systems, it is more appropriate to
+# uncomment the following two lines:
+#main.o: main.c
+# $(CC) -c -Donexit=on_exit -DSkip_f2c_Undefs main.c
+
+install: libF77.a
+ mv libF77.a /usr/lib
+
+clean:
+ rm -f libF77.a *.o
+
+check:
+ xsum Notice README Version.c abort_.c c_abs.c c_cos.c c_div.c \
+ c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \
+ d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \
+ d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \
+ d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \
+ derf_.c derfc_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c getarg_.c \
+ getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c h_mod.c \
+ h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c i_abs.c \
+ i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c i_sign.c \
+ iargc_.c l_ge.c l_gt.c l_le.c l_lt.c main.c makefile pow_ci.c \
+ pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_ri.c pow_zi.c pow_zz.c \
+ r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c r_cnjg.c r_cos.c \
+ r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c r_log.c \
+ r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c r_tan.c \
+ r_tanh.c s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c \
+ sig_die.c signal_.c system_.c z_abs.c z_cos.c z_div.c z_exp.c \
+ z_log.c z_sin.c z_sqrt.c >zap
+ cmp zap libF77.xsum && rm zap || diff libF77.xsum zap
--- /dev/null
+#include "f2c.h"
+
+VOID pow_ci(p, a, b) /* p = a**b */
+complex *p, *a;
+integer *b;
+{
+doublecomplex p1, a1;
+
+a1.r = a->r;
+a1.i = a->i;
+
+pow_zi(&p1, &a1, b);
+
+p->r = p1.r;
+p->i = p1.i;
+}
--- /dev/null
+#include "f2c.h"
+
+double pow_dd(ap, bp)
+doublereal *ap, *bp;
+{
+double pow();
+
+return(pow(*ap, *bp) );
+}
--- /dev/null
+#include "f2c.h"
+
+double pow_di(ap, bp)
+doublereal *ap;
+integer *bp;
+{
+double pow, x;
+integer n;
+
+pow = 1;
+x = *ap;
+n = *bp;
+
+if(n != 0)
+ {
+ if(n < 0)
+ {
+ if(x == 0)
+ {
+ return(pow);
+ }
+ n = -n;
+ x = 1/x;
+ }
+ for( ; ; )
+ {
+ if(n & 01)
+ pow *= x;
+ if(n >>= 1)
+ x *= x;
+ else
+ break;
+ }
+ }
+return(pow);
+}
--- /dev/null
+#include "f2c.h"
+
+shortint pow_hh(ap, bp)
+shortint *ap, *bp;
+{
+shortint pow, x, n;
+
+pow = 1;
+x = *ap;
+n = *bp;
+
+if(n < 0)
+ { }
+else if(n > 0)
+ for( ; ; )
+ {
+ if(n & 01)
+ pow *= x;
+ if(n >>= 1)
+ x *= x;
+ else
+ break;
+ }
+return(pow);
+}
--- /dev/null
+#include "f2c.h"
+
+integer pow_ii(ap, bp)
+integer *ap, *bp;
+{
+integer pow, x, n;
+
+pow = 1;
+x = *ap;
+n = *bp;
+
+if(n < 0)
+ { }
+else if(n > 0)
+ for( ; ; )
+ {
+ if(n & 01)
+ pow *= x;
+ if(n >>= 1)
+ x *= x;
+ else
+ break;
+ }
+return(pow);
+}
--- /dev/null
+#include "f2c.h"
+
+double pow_ri(ap, bp)
+real *ap;
+integer *bp;
+{
+double pow, x;
+integer n;
+
+pow = 1;
+x = *ap;
+n = *bp;
+
+if(n != 0)
+ {
+ if(n < 0)
+ {
+ if(x == 0)
+ {
+ return(pow);
+ }
+ n = -n;
+ x = 1/x;
+ }
+ for( ; ; )
+ {
+ if(n & 01)
+ pow *= x;
+ if(n >>= 1)
+ x *= x;
+ else
+ break;
+ }
+ }
+return(pow);
+}
--- /dev/null
+#include "f2c.h"
+
+VOID pow_zi(p, a, b) /* p = a**b */
+doublecomplex *p, *a;
+integer *b;
+{
+integer n;
+double t;
+doublecomplex x;
+static doublecomplex one = {1.0, 0.0};
+
+n = *b;
+p->r = 1;
+p->i = 0;
+
+if(n == 0)
+ return;
+if(n < 0)
+ {
+ n = -n;
+ z_div(&x, &one, a);
+ }
+else
+ {
+ x.r = a->r;
+ x.i = a->i;
+ }
+
+for( ; ; )
+ {
+ if(n & 01)
+ {
+ t = p->r * x.r - p->i * x.i;
+ p->i = p->r * x.i + p->i * x.r;
+ p->r = t;
+ }
+ if(n >>= 1)
+ {
+ t = x.r * x.r - x.i * x.i;
+ x.i = 2 * x.r * x.i;
+ x.r = t;
+ }
+ else
+ break;
+ }
+}
--- /dev/null
+#include "f2c.h"
+
+VOID pow_zz(r,a,b)
+doublecomplex *r, *a, *b;
+{
+double logr, logi, x, y;
+double log(), exp(), cos(), sin(), atan2(), cabs();
+
+logr = log( cabs(a->r, a->i) );
+logi = atan2(a->i, a->r);
+
+x = exp( logr * b->r - logi * b->i );
+y = logr * b->i + logi * b->r;
+
+r->r = x * cos(y);
+r->i = x * sin(y);
+}
--- /dev/null
+#include "f2c.h"
+
+double r_abs(x)
+real *x;
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
--- /dev/null
+#include "f2c.h"
+
+double r_acos(x)
+real *x;
+{
+double acos();
+return( acos(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_asin(x)
+real *x;
+{
+double asin();
+return( asin(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_atan(x)
+real *x;
+{
+double atan();
+return( atan(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_atn2(x,y)
+real *x, *y;
+{
+double atan2();
+return( atan2(*x,*y) );
+}
--- /dev/null
+#include "f2c.h"
+
+VOID r_cnjg(r, z)
+complex *r, *z;
+{
+r->r = z->r;
+r->i = - z->i;
+}
--- /dev/null
+#include "f2c.h"
+
+double r_cos(x)
+real *x;
+{
+double cos();
+return( cos(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_cosh(x)
+real *x;
+{
+double cosh();
+return( cosh(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_dim(a,b)
+real *a, *b;
+{
+return( *a > *b ? *a - *b : 0);
+}
--- /dev/null
+#include "f2c.h"
+
+double r_exp(x)
+real *x;
+{
+double exp();
+return( exp(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_imag(z)
+complex *z;
+{
+return(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+double r_int(x)
+real *x;
+{
+double floor();
+
+return( (*x>0) ? floor(*x) : -floor(- *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+#define log10e 0.43429448190325182765
+
+double r_lg10(x)
+real *x;
+{
+double log();
+
+return( log10e * log(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_log(x)
+real *x;
+{
+double log();
+return( log(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_mod(x,y)
+real *x, *y;
+{
+#ifdef IEEE_drem
+ double drem(), xa, ya, z;
+ if ((ya = *y) < 0.)
+ ya = -ya;
+ z = drem(xa = *x, ya);
+ if (xa > 0) {
+ if (z < 0)
+ z += ya;
+ }
+ else if (z > 0)
+ z -= ya;
+ return z;
+#else
+ double floor(), quotient;
+ if( (quotient = (double)*x / *y) >= 0)
+ quotient = floor(quotient);
+ else
+ quotient = -floor(-quotient);
+ return(*x - (*y) * quotient );
+#endif
+}
--- /dev/null
+#include "f2c.h"
+
+double r_nint(x)
+real *x;
+{
+double floor();
+
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_sign(a,b)
+real *a, *b;
+{
+double x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
--- /dev/null
+#include "f2c.h"
+
+double r_sin(x)
+real *x;
+{
+double sin();
+return( sin(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_sinh(x)
+real *x;
+{
+double sinh();
+return( sinh(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_sqrt(x)
+real *x;
+{
+double sqrt();
+return( sqrt(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_tan(x)
+real *x;
+{
+double tan();
+return( tan(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+double r_tanh(x)
+real *x;
+{
+double tanh();
+return( tanh(*x) );
+}
--- /dev/null
+#include "f2c.h"
+
+VOID s_cat(lp, rpp, rnp, np, ll)
+char *lp, *rpp[];
+ftnlen rnp[], *np, ll;
+{
+int i, n, nc;
+char *rp;
+
+n = *np;
+for(i = 0 ; i < n ; ++i)
+ {
+ nc = ll;
+ if(rnp[i] < nc)
+ nc = rnp[i];
+ ll -= nc;
+ rp = rpp[i];
+ while(--nc >= 0)
+ *lp++ = *rp++;
+ }
+while(--ll >= 0)
+ *lp++ = ' ';
+}
--- /dev/null
+#include "f2c.h"
+
+integer s_cmp(a, b, la, lb) /* compare two strings */
+register char *a, *b;
+long int la, lb;
+{
+register char *aend, *bend;
+aend = a + la;
+bend = b + lb;
+
+if(la <= lb)
+ {
+ while(a < aend)
+ if(*a != *b)
+ return( *a - *b );
+ else
+ { ++a; ++b; }
+
+ while(b < bend)
+ if(*b != ' ')
+ return( ' ' - *b );
+ else ++b;
+ }
+
+else
+ {
+ while(b < bend)
+ if(*a == *b)
+ { ++a; ++b; }
+ else
+ return( *a - *b );
+ while(a < aend)
+ if(*a != ' ')
+ return(*a - ' ');
+ else ++a;
+ }
+return(0);
+}
--- /dev/null
+#include "f2c.h"
+
+VOID s_copy(a, b, la, lb) /* assign strings: a = b */
+char *a, *b;
+long int la, lb;
+{
+char *aend, *bend;
+
+aend = a + la;
+
+if(la <= lb)
+ while(a < aend)
+ *a++ = *b++;
+
+else
+ {
+ bend = b + lb;
+ while(b < bend)
+ *a++ = *b++;
+ while(a < aend)
+ *a++ = ' ';
+ }
+}
--- /dev/null
+#include "stdio.h"
+#include "f2c.h"
+#define PAUSESIG 15
+
+static waitpause()
+{
+return;
+}
+
+VOID s_paus(s, n)
+char *s;
+long int n;
+{
+int i;
+
+fprintf(stderr, "PAUSE ");
+if(n > 0)
+ for(i = 0; i<n ; ++i)
+ putc(*s++, stderr);
+fprintf(stderr, " statement executed\n");
+if( isatty(fileno(stdin)) )
+ {
+ fprintf(stderr, "To resume execution, type go. Any other input will terminate job.\n");
+ fflush(stderr);
+ if( getchar()!='g' || getchar()!='o' || getchar()!='\n' )
+ {
+ fprintf(stderr, "STOP\n");
+ f_exit();
+ exit(0);
+ }
+ }
+else
+ {
+ fprintf(stderr, "To resume execution, execute a kill -%d %d command\n",
+ PAUSESIG, getpid() );
+ signal(PAUSESIG, waitpause);
+ fflush(stderr);
+ pause();
+ }
+fprintf(stderr, "Execution resumes after PAUSE.\n");
+}
--- /dev/null
+#include "stdio.h"
+#include "f2c.h"
+
+extern VOID sig_die();
+
+/* called when a subscript is out of range */
+
+VOID s_rnge(varn, offset, procn, line)
+char *varn, *procn;
+long int offset, line;
+{
+register int i;
+
+fprintf(stderr, "Subscript out of range on file line %ld, procedure ", line);
+while((i = *procn) && i != '_' && i != ' ')
+ putc(*procn++, stderr);
+fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", offset+1);
+while((i = *varn) && i != ' ')
+ putc(*varn++, stderr);
+sig_die(".", 1);
+}
--- /dev/null
+#include "stdio.h"
+#include "f2c.h"
+
+VOID s_stop(s, n)
+char *s;
+long int n;
+{
+int i;
+
+if(n > 0)
+ {
+ fprintf(stderr, "STOP ");
+ for(i = 0; i<n ; ++i)
+ putc(*s++, stderr);
+ fprintf(stderr, " statement executed\n");
+ }
+f_exit();
+exit(0);
+}
--- /dev/null
+#include "stdio.h"
+#include "signal.h"
+
+#ifndef SIGIOT
+#define SIGIOT SIGABRT
+#endif
+
+ void
+sig_die(s, kill)
+register char *s;
+int kill;
+{
+ /* print error message, then clear buffers */
+ extern void exit(), f_exit();
+ fprintf(stderr, "%s\n", s);
+ fflush(stderr);
+ f_exit();
+ fflush(stderr);
+
+ if(kill)
+ {
+ /* now get a core */
+ signal(SIGIOT, SIG_DFL);
+ abort();
+ }
+ else
+ exit(1);
+ }
--- /dev/null
+#include "f2c.h"
+
+typedef int (*sig_type)();
+extern sig_type signal();
+
+integer signal_(sigp, procp)
+integer *sigp, *procp;
+{
+ int sig;
+ sig_type proc;
+ sig = *sigp;
+ proc = *(sig_type *)procp;
+
+ return (integer)signal(sig, proc);
+ }
--- /dev/null
+/* f77 interface to system routine */
+
+#include "f2c.h"
+
+ integer
+system_(s, n)
+register char *s;
+long int n;
+{
+char buff[1000];
+register char *bp, *blast;
+
+blast = buff + (n < 1000 ? n : 1000);
+
+for(bp = buff ; bp<blast && *s!='\0' ; )
+ *bp++ = *s++;
+*bp = '\0';
+return system(buff);
+}
--- /dev/null
+#include "f2c.h"
+
+double z_abs(z)
+doublecomplex *z;
+{
+double cabs();
+
+return( cabs( z->r, z->i ) );
+}
--- /dev/null
+#include "f2c.h"
+
+VOID z_cos(r, z)
+doublecomplex *r, *z;
+{
+double sin(), cos(), sinh(), cosh();
+
+r->r = cos(z->r) * cosh(z->i);
+r->i = - sin(z->r) * sinh(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+extern VOID sig_die();
+
+VOID z_div(c, a, b)
+doublecomplex *a, *b, *c;
+{
+double ratio, den;
+double abr, abi;
+
+if( (abr = b->r) < 0.)
+ abr = - abr;
+if( (abi = b->i) < 0.)
+ abi = - abi;
+if( abr <= abi )
+ {
+ if(abi == 0)
+ sig_die("complex division by zero", 1);
+ ratio = b->r / b->i ;
+ den = b->i * (1 + ratio*ratio);
+ c->r = (a->r*ratio + a->i) / den;
+ c->i = (a->i*ratio - a->r) / den;
+ }
+
+else
+ {
+ ratio = b->i / b->r ;
+ den = b->r * (1 + ratio*ratio);
+ c->r = (a->r + a->i*ratio) / den;
+ c->i = (a->i - a->r*ratio) / den;
+ }
+
+}
--- /dev/null
+#include "f2c.h"
+
+VOID z_exp(r, z)
+doublecomplex *r, *z;
+{
+double expx;
+double exp(), cos(), sin();
+
+expx = exp(z->r);
+r->r = expx * cos(z->i);
+r->i = expx * sin(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+VOID z_log(r, z)
+doublecomplex *r, *z;
+{
+double log(), cabs(), atan2();
+
+r->i = atan2(z->i, z->r);
+r->r = log( cabs( z->r, z->i ) );
+}
--- /dev/null
+#include "f2c.h"
+
+VOID z_sin(r, z)
+doublecomplex *r, *z;
+{
+double sin(), cos(), sinh(), cosh();
+
+r->r = sin(z->r) * cosh(z->i);
+r->i = cos(z->r) * sinh(z->i);
+}
--- /dev/null
+#include "f2c.h"
+
+VOID z_sqrt(r, z)
+doublecomplex *r, *z;
+{
+double mag, sqrt(), cabs();
+
+if( (mag = cabs(z->r, z->i)) == 0.)
+ r->r = r->i = 0.;
+else if(z->r > 0)
+ {
+ r->r = sqrt(0.5 * (mag + z->r) );
+ r->i = z->i / r->r / 2;
+ }
+else
+ {
+ r->i = sqrt(0.5 * (mag - z->r) );
+ if(z->i < 0)
+ z->i = - z->i;
+ r->r = z->i / r->i / 2;
+ }
+}
--- /dev/null
+LIST
+Notice
+README
+Version.c
+backspace.c
+close.c
+dfe.c
+dolio.c
+due.c
+endfile.c
+err.c
+fio.h
+fmt.c
+fmt.h
+fmtlib.c
+fp.h
+iio.c
+ilnw.c
+inquire.c
+libI77.xsum
+lio.h
+local.h
+lread.c
+lwrite.c
+makefile
+open.c
+rdfmt.c
+rewind.c
+rsfe.c
+rsli.c
+rsne.c
+sfe.c
+sue.c
+typesize.c
+uio.c
+util.c
+wref.c
+wrtfmt.c
+wsfe.c
+wsle.c
+wsne.c
+xwsne.c
--- /dev/null
+Version.c
+backspace.c
+close.c
+dfe.c
+dolio.c
+due.c
+endfile.c
+err.c
+fio.h
+fmt.c
+fmt.h
+fmtlib.c
+fp.h
+iio.c
+ilnw.c
+inquire.c
+lio.h
+local.h
+lread.c
+lwrite.c
+open.c
+rdfmt.c
+rewind.c
+rsfe.c
+rsli.c
+rsne.c
+sfe.c
+sue.c
+typesize.c
+uio.c
+util.c
+wref.c
+wrtfmt.c
+wsfe.c
+wsle.c
+wsne.c
+xwsne.c
--- /dev/null
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
--- /dev/null
+If your system lacks /usr/include/local.h ,
+then you should create an appropriate local.h in
+this directory. An appropriate local.h may simply
+be empty, or it may #define VAX or #define CRAY
+(or whatever else you must do to make fp.h work right).
+Alternatively, edit fp.h to suite your machine.
+
+If your system lacks /usr/include/fcntl.h , then you
+should simply create an empty fcntl.h in this directory.
+
+If your system's sprintf does not work the way ANSI C
+specifies -- specifically, if it does not return the
+number of characters transmitted -- then insert the line
+
+#define USE_STRLEN
+
+at the end of fmt.h . This is necessary with
+at least some versions of Sun software.
+
+If your system's fopen does not like the ANSI binary
+reading and writing modes "rb" and "wb", then you should
+compile open.c with NON_ANSI_RW_MODES #defined.
+
+If you get error messages about references to cf->_ptr
+and cf->_base when compiling wrtfmt.c and wsfe.c or to
+stderr->_flag when compiling err.c, then insert the line
+
+#define NON_UNIX_STDIO
+
+at the beginning of fio.h, and recompile these modules.
+
+You may need to supply the following non-ANSI routines:
+
+ fstat(int fileds, struct stat *buf) is similar
+to stat(char *name, struct stat *buf), except that
+the first argument, fileds, is the file descriptor
+returned by open rather than the name of the file.
+fstat is used in the system-dependent routine
+canseek (in the libI77 source file err.c), which
+is supposed to return 1 if it's possible to issue
+seeks on the file in question, 0 if it's not; you may
+need to suitably modify err.c . On non-UNIX systems,
+you can avoid references to fstat and stat by compiling
+err.c, inquire.c, open.c, and util.c with MSDOS defined;
+in that case, you may need to supply access(char *Name,0),
+which is supposed to return 0 if file Name exists,
+nonzero otherwise.
+
+ char * mktemp(char *buf) is supposed to replace the
+6 trailing X's in buf with a unique number and then
+return buf. The idea is to get a unique name for
+a temporary file.
+
+On non-UNIX systems, you may need to change a few other,
+e.g.: the form of name computed by mktemp() in endfile.c and
+open.c; the use of the open(), close(), and creat() system
+calls in endfile.c, err.c, open.c; and the modes in calls on
+fopen() and fdopen() (and perhaps the use of fdopen() itself
+-- it's supposed to return a FILE* corresponding to a given
+an integer file descriptor) in err.c and open.c (component ufmt
+of struct unit is 1 for formatted I/O -- text mode on some systems
+-- and 0 for unformatted I/O -- binary mode on some systems).
+
+For Turbo C++, in particular, you need to adjust the mktemp
+invocations and should compile all of libI77 with -DMSDOS .
+You also need to #undef ungetc in lread.c and rsne.c .
+Don't use -mh -- it is horribly broken.
+
+If you want to be able to load against libI77 but not libF77,
+then you will need to add sig_die.o (from libF77) to libI77.
+
+If you wish to use translated Fortran that has funny notions
+of record length for direct unformatted I/O (i.e., that assumes
+RECL= values in OPEN statements are not bytes but rather counts
+of some other units -- e.g., 4-character words for VMS), then you
+should insert an appropriate #define for url_Adjust at the
+beginning of open.c . For VMS Fortran, for example,
+#define url_Adjust(x) x *= 4
+would suffice.
+
+To check for transmission errors, issue the command
+ make check
+This assumes you have the xsum program whose source, xsum.c,
+is distributed as part of "all from f2c/src". If you do not
+have xsum, you can obtain xsum.c by sending the following E-mail
+message to netlib@research.att.com
+ send xsum.c from f2c/src
+
+The makefile assumes you have installed f2c.h in a standard
+place (and does not cause recompilation when f2c.h is changed);
+f2c.h comes with "all from f2c" (the source for f2c) and is
+available separately ("f2c.h from f2c").
--- /dev/null
+static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 16 May 1991\n";
+
+/*
+2.01 $ format added
+2.02 Coding bug in open.c repaired
+2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c
+ and lio.h (e-format conforming to spec)
+2.04 changed open.c and err.c (fopen and freopen respectively) to
+ update to new c-library (append mode)
+2.05 added namelist capability
+2.06 allow internal list and namelist I/O
+*/
+
+/*
+close.c:
+ allow upper-case STATUS= values
+endfile.c
+ create fort.nnn if unit nnn not open;
+ else if (file length == 0) use creat() rather than copy;
+ use local copy() rather than forking /bin/cp;
+ rewind, fseek to clear buffer (for no reading past EOF)
+err.c
+ use neither setbuf nor setvbuf; make stderr buffered
+fio.h
+ #define _bufend
+inquire.c
+ upper case responses;
+ omit byfile test from SEQUENTIAL=
+ answer "YES" to DIRECT= for unopened file (open to debate)
+lio.c
+ flush stderr, stdout at end of each stmt
+ space before character strings in list output only at line start
+lio.h
+ adjust LEW, LED consistent with old libI77
+lread.c
+ use atof()
+ allow "nnn*," when reading complex constants
+open.c
+ try opening for writing when open for read fails, with
+ special uwrt value (2) delaying creat() to first write;
+ set curunit so error messages don't drop core;
+ no file name ==> fort.nnn except for STATUS='SCRATCH'
+rdfmt.c
+ use atof(); trust EOF == end-of-file (so don't read past
+ end-of-file after endfile stmt)
+sfe.c
+ flush stderr, stdout at end of each stmt
+wrtfmt.c:
+ use upper case
+ put wrt_E and wrt_F into wref.c, use sprintf()
+ rather than ecvt() and fcvt() [more accurate on VAX]
+*/
+
+/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */
+
+/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */
+
+/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */
+/* 29 Nov. 1989: change various int return types to long for f2c */
+/* 30 Nov. 1989: various types from f2c.h */
+/* 6 Dec. 1989: types corrected various places */
+/* 19 Dec. 1989: make iostat= work right for internal I/O */
+/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */
+/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white
+ space as blank */
+/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads
+ of logical values reject letters other than fFtT;
+ have nowwriting reset cf */
+/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */
+/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as
+ blank='z...' when reopening an open file */
+/* 30 Aug. 1990: prevent embedded blanks in list output of complex values;
+ omit exponent field in list output of values of
+ magnitude between 10 and 1e8; prevent writing stdin
+ and reading stdout or stderr; don't close stdin, stdout,
+ or stderr when reopening units 5, 6, 0. */
+/* 18 Sep. 1990: add component udev to unit and consider old == new file
+ iff uinode and udev values agree; use stat rather than
+ access to check existence of file (when STATUS='OLD')*/
+/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write
+ don't clobber the file. */
+/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c;
+ adjust g_char in util.c for segmented memories. */
+/* 17 Oct. 1990: replace abort() and _cleanup() with calls on
+ sig_die(...,1) (defined in main.c). */
+/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the
+ file already exists; allow file= to be omitted in open stmts
+ and allow status='replace' (Fortran 90 extensions). */
+/* 11 Dec. 1990: adjustments for POSIX. */
+/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from
+ strings in read-only memory. */
+/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */
+/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */
+/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+integer f_back(a) alist *a;
+{ unit *b;
+ int n,i;
+ long x;
+ char buf[32];
+ if(a->aunit >= MXUNIT || a->aunit < 0)
+ err(a->aerr,101,"backspace")
+ b= &units[a->aunit];
+ if(b->useek==0) err(a->aerr,106,"backspace")
+ if(b->ufd==NULL) {
+ fk_open(1, 1, a->aunit);
+ return(0);
+ }
+ if(b->uend==1)
+ { b->uend=0;
+ return(0);
+ }
+ if(b->uwrt) {
+ (void) t_runc(a);
+ if (nowreading(b))
+ err(a->aerr,errno,"backspace")
+ }
+ if(b->url>0)
+ { long y;
+ x=ftell(b->ufd);
+ y = x % b->url;
+ if(y == 0) x--;
+ x /= b->url;
+ x *= b->url;
+ (void) fseek(b->ufd,x,SEEK_SET);
+ return(0);
+ }
+
+ if(b->ufmt==0)
+ { (void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR);
+ (void) fread((char *)&n,sizeof(int),1,b->ufd);
+ (void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR);
+ return(0);
+ }
+ for(;;)
+ { long y;
+ y = x=ftell(b->ufd);
+ if(x<sizeof(buf)) x=0;
+ else x -= sizeof(buf);
+ (void) fseek(b->ufd,x,SEEK_SET);
+ n=fread(buf,1,(int)(y-x), b->ufd);
+ for(i=n-2;i>=0;i--)
+ {
+ if(buf[i]!='\n') continue;
+ (void) fseek(b->ufd,(long)(i+1-n),SEEK_CUR);
+ return(0);
+ }
+ if(x==0)
+ {
+ (void) fseek(b->ufd, 0L, SEEK_SET);
+ return(0);
+ }
+ else if(n<=0) err(a->aerr,(EOF),"backspace")
+ (void) fseek(b->ufd, x, SEEK_SET);
+ }
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+integer f_clos(a) cllist *a;
+{ unit *b;
+ if(a->cunit >= MXUNIT) return(0);
+ b= &units[a->cunit];
+ if(b->ufd==NULL)
+ goto done;
+ if (!a->csta)
+ if (b->uscrtch == 1)
+ goto delete;
+ else
+ goto keep;
+ switch(*a->csta) {
+ default:
+ keep:
+ case 'k':
+ case 'K':
+ if(b->uwrt == 1)
+ (void) t_runc((alist *)a);
+ if(b->ufnm) {
+ (void) fclose(b->ufd);
+ free(b->ufnm);
+ }
+ break;
+ case 'd':
+ case 'D':
+ delete:
+ if(b->ufnm) {
+ (void) fclose(b->ufd);
+ (void) unlink(b->ufnm); /*SYSDEP*/
+ free(b->ufnm);
+ }
+ }
+ b->ufd=NULL;
+ done:
+ b->uend=0;
+ b->ufnm=NULL;
+ return(0);
+ }
+ void
+f_exit()
+{ int i;
+ static cllist xx;
+ if (!xx.cerr) {
+ xx.cerr=1;
+ xx.csta=NULL;
+ for(i=0;i<MXUNIT;i++)
+ {
+ xx.cunit=i;
+ (void) f_clos(&xx);
+ }
+ }
+}
+flush_()
+{ int i;
+ for(i=0;i<MXUNIT;i++)
+ if(units[i].ufd != NULL) (void) fflush(units[i].ufd);
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+extern int rd_ed(),rd_ned(),y_getc(),y_putc(),y_err();
+extern int y_rev(), y_rsk(), y_newrec();
+extern int w_ed(),w_ned();
+integer s_rdfe(a) cilist *a;
+{
+ int n;
+ if(!init) f_init();
+ if(n=c_dfe(a))return(n);
+ reading=1;
+ if(curunit->uwrt && nowreading(curunit))
+ err(a->cierr,errno,"read start");
+ getn = y_getc;
+ doed = rd_ed;
+ doned = rd_ned;
+ dorevert = donewrec = y_err;
+ doend = y_rsk;
+ if(pars_f(fmtbuf)<0)
+ err(a->cierr,100,"read start");
+ fmt_bg();
+ return(0);
+}
+integer s_wdfe(a) cilist *a;
+{
+ int n;
+ if(!init) f_init();
+ if(n=c_dfe(a)) return(n);
+ reading=0;
+ if(curunit->uwrt != 1 && nowwriting(curunit))
+ err(a->cierr,errno,"startwrt");
+ putn = y_putc;
+ doed = w_ed;
+ doned= w_ned;
+ dorevert = y_err;
+ donewrec = y_newrec;
+ doend = y_rev;
+ if(pars_f(fmtbuf)<0)
+ err(a->cierr,100,"startwrt");
+ fmt_bg();
+ return(0);
+}
+integer e_rdfe()
+{
+ (void) en_fio();
+ return(0);
+}
+integer e_wdfe()
+{
+ (void) en_fio();
+ return(0);
+}
+c_dfe(a) cilist *a;
+{
+ sequential=0;
+ formatted=external=1;
+ elist=a;
+ cursor=scale=recpos=0;
+ if(a->ciunit>MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"startchk");
+ curunit = &units[a->ciunit];
+ if(curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
+ err(a->cierr,104,"dfe");
+ cf=curunit->ufd;
+ if(!curunit->ufmt) err(a->cierr,102,"dfe")
+ if(!curunit->useek) err(a->cierr,104,"dfe")
+ fmtbuf=a->cifmt;
+ (void) fseek(cf,(long)curunit->url * (a->cirec-1),SEEK_SET);
+ curunit->uend = 0;
+ return(0);
+}
+y_rsk()
+{
+ if(curunit->uend || curunit->url <= recpos
+ || curunit->url == 1) return 0;
+ do {
+ getc(cf);
+ } while(++recpos < curunit->url);
+ return 0;
+}
+y_getc()
+{
+ int ch;
+ if(curunit->uend) return(-1);
+ if((ch=getc(cf))!=EOF)
+ {
+ recpos++;
+ if(curunit->url>=recpos ||
+ curunit->url==1)
+ return(ch);
+ else return(' ');
+ }
+ if(feof(cf))
+ {
+ curunit->uend=1;
+ errno=0;
+ return(-1);
+ }
+ err(elist->cierr,errno,"readingd");
+}
+y_putc(c)
+{
+ recpos++;
+ if(recpos <= curunit->url || curunit->url==1)
+ putc(c,cf);
+ else
+ err(elist->cierr,110,"dout");
+ return(0);
+}
+y_rev()
+{ /*what about work done?*/
+ if(curunit->url==1 || recpos==curunit->url)
+ return(0);
+ while(recpos<curunit->url)
+ (*putn)(' ');
+ recpos=0;
+ return(0);
+}
+y_err()
+{
+ err(elist->cierr, 110, "dfe");
+}
+
+y_newrec()
+{
+ if(curunit->url == 1 || recpos == curunit->url) {
+ hiwater = recpos = cursor = 0;
+ return(1);
+ }
+ if(hiwater > recpos)
+ recpos = hiwater;
+ y_rev();
+ hiwater = cursor = 0;
+ return(1);
+}
--- /dev/null
+#include "f2c.h"
+extern int (*lioproc)();
+
+integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
+{
+ return((*lioproc)(number,ptr,len,*type));
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+integer s_rdue(a) cilist *a;
+{
+ int n;
+ if(n=c_due(a)) return(n);
+ reading=1;
+ if(curunit->uwrt && nowreading(curunit))
+ err(a->cierr,errno,"read start");
+ return(0);
+}
+integer s_wdue(a) cilist *a;
+{
+ int n;
+ if(n=c_due(a)) return(n);
+ reading=0;
+ if(curunit->uwrt != 1 && nowwriting(curunit))
+ err(a->cierr,errno,"write start");
+ return(0);
+}
+c_due(a) cilist *a;
+{
+ if(!init) f_init();
+ if(a->ciunit>=MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"startio");
+ recpos=sequential=formatted=0;
+ external=1;
+ curunit = &units[a->ciunit];
+ elist=a;
+ if(curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
+ cf=curunit->ufd;
+ if(curunit->ufmt) err(a->cierr,102,"cdue")
+ if(!curunit->useek) err(a->cierr,104,"cdue")
+ if(curunit->ufd==NULL) err(a->cierr,114,"cdue")
+ (void) fseek(cf,(long)(a->cirec-1)*curunit->url,SEEK_SET);
+ curunit->uend = 0;
+ return(0);
+}
+integer e_rdue()
+{
+ if(curunit->url==1 || recpos==curunit->url)
+ return(0);
+ (void) fseek(cf,(long)(curunit->url-recpos),SEEK_CUR);
+ if(ftell(cf)%curunit->url)
+ err(elist->cierr,200,"syserr");
+ return(0);
+}
+integer e_wdue()
+{
+ return(e_rdue());
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "sys/types.h"
+#include "fcntl.h"
+#ifndef O_RDONLY
+#define O_RDONLY 0
+#endif
+
+extern char *mktemp(), *strcpy();
+
+integer f_end(a) alist *a;
+{
+ unit *b;
+ if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
+ b = &units[a->aunit];
+ if(b->ufd==NULL) {
+ char nbuf[10];
+ (void) sprintf(nbuf,"fort.%ld",a->aunit);
+ close(creat(nbuf, 0666));
+ return(0);
+ }
+ b->uend=1;
+ return(b->useek ? t_runc(a) : 0);
+}
+
+ static int
+copy(from, len, to)
+ char *from, *to;
+ register long len;
+{
+ register int n;
+ int k, rc = 0, tmp;
+ char buf[BUFSIZ];
+
+ if ((k = open(from, O_RDONLY)) < 0)
+ return 1;
+ if ((tmp = creat(to,0666)) < 0)
+ return 1;
+ while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
+ if (write(tmp, buf, n) != n)
+ { rc = 1; break; }
+ if ((len -= n) <= 0)
+ break;
+ }
+ close(k);
+ close(tmp);
+ return n < 0 ? 1 : rc;
+ }
+
+t_runc(a) alist *a;
+{
+ char nm[16];
+ long loc, len;
+ unit *b;
+ int rc = 0;
+
+ b = &units[a->aunit];
+ if(b->url) return(0); /*don't truncate direct files*/
+ loc=ftell(b->ufd);
+ (void) fseek(b->ufd,0L,SEEK_END);
+ len=ftell(b->ufd);
+ if (loc >= len || b->useek == 0 || b->ufnm == NULL)
+ return(0);
+ rewind(b->ufd); /* empty buffer */
+ if (!loc) {
+ if (close(creat(b->ufnm,0666)))
+ { rc = 1; goto done; }
+ if (b->uwrt)
+ b->uwrt = 1;
+ return 0;
+ }
+ (void) strcpy(nm,"tmp.FXXXXXX");
+ (void) mktemp(nm);
+ if (copy(b->ufnm, loc, nm)
+ || copy(nm, loc, b->ufnm))
+ rc = 1;
+ unlink(nm);
+done:
+ fseek(b->ufd, loc, SEEK_SET);
+ if (rc)
+ err(a->aerr,111,"endfile");
+ return 0;
+ }
--- /dev/null
+#include "sys/types.h"
+#ifndef MSDOS
+#include "sys/stat.h"
+#endif
+#include "f2c.h"
+#include "fio.h"
+#include "fcntl.h"
+#ifndef O_WRONLY
+#define O_WRONLY 1
+#endif
+
+extern FILE *fdopen();
+
+/*global definitions*/
+unit units[MXUNIT]; /*unit table*/
+flag init; /*0 on entry, 1 after initializations*/
+cilist *elist; /*active external io list*/
+flag reading; /*1 if reading, 0 if writing*/
+flag cplus,cblank;
+char *fmtbuf;
+flag external; /*1 if external io, 0 if internal */
+int (*doed)(),(*doned)();
+int (*doend)(),(*donewrec)(),(*dorevert)();
+flag sequential; /*1 if sequential io, 0 if direct*/
+flag formatted; /*1 if formatted io, 0 if unformatted*/
+int (*getn)(),(*putn)(); /*for formatted io*/
+FILE *cf; /*current file*/
+unit *curunit; /*current unit*/
+int recpos; /*place in current record*/
+int cursor,scale;
+
+/*error messages*/
+char *F_err[] =
+{
+ "error in format", /* 100 */
+ "illegal unit number", /* 101 */
+ "formatted io not allowed", /* 102 */
+ "unformatted io not allowed", /* 103 */
+ "direct io not allowed", /* 104 */
+ "sequential io not allowed", /* 105 */
+ "can't backspace file", /* 106 */
+ "null file name", /* 107 */
+ "can't stat file", /* 108 */
+ "unit not connected", /* 109 */
+ "off end of record", /* 110 */
+ "truncation failed in endfile", /* 111 */
+ "incomprehensible list input", /* 112 */
+ "out of free space", /* 113 */
+ "unit not connected", /* 114 */
+ "read unexpected character", /* 115 */
+ "bad logical input field", /* 116 */
+ "bad variable type", /* 117 */
+ "bad namelist name", /* 118 */
+ "variable not in namelist", /* 119 */
+ "no end record", /* 120 */
+ "variable count incorrect", /* 121 */
+ "subscript for scalar variable", /* 122 */
+ "invalid array section", /* 123 */
+ "substring out of bounds", /* 124 */
+ "subscript out of bounds", /* 125 */
+ "can't read file", /* 126 */
+ "can't write file", /* 127 */
+ "'new' file exists" /* 128 */
+};
+#define MAXERR (sizeof(F_err)/sizeof(char *)+100)
+fatal(n,s) char *s;
+{
+ if(n<100 && n>=0) perror(s); /*SYSDEP*/
+ else if(n >= (int)MAXERR || n < -1)
+ { fprintf(stderr,"%s: illegal error number %d\n",s,n);
+ }
+ else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
+ else
+ fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
+ if (curunit) {
+ fprintf(stderr,"apparent state: unit %d ",curunit-units);
+ fprintf(stderr, curunit->ufnm ? "named %s\n" : "(unnamed)\n",
+ curunit->ufnm);
+ }
+ else
+ fprintf(stderr,"apparent state: internal I/O\n");
+ if (fmtbuf)
+ fprintf(stderr,"last format: %s\n",fmtbuf);
+ fprintf(stderr,"lately %s %s %s %s",reading?"reading":"writing",
+ sequential?"sequential":"direct",formatted?"formatted":"unformatted",
+ external?"external":"internal");
+ sig_die(" IO", 1);
+}
+/*initialization routine*/
+f_init()
+{ unit *p;
+
+ init=1;
+ p= &units[0];
+ p->ufd=stderr;
+ p->useek=canseek(stderr);
+#ifdef COMMENTED_OUT
+ if(isatty(fileno(stderr))) {
+ extern char *malloc();
+ setbuf(stderr, malloc(BUFSIZ));
+ /* setvbuf(stderr, _IOLBF, 0, 0); */
+ } /* wastes space, but win for debugging in windows */
+#endif
+#ifdef NON_UNIX_STDIO
+ {extern char *malloc(); setbuf(stderr, malloc(BUFSIZ));}
+#else
+ stderr->_flag &= ~_IONBF;
+#endif
+ p->ufmt=1;
+ p->uwrt=1;
+ p = &units[5];
+ p->ufd=stdin;
+ p->useek=canseek(stdin);
+ p->ufmt=1;
+ p->uwrt=0;
+ p= &units[6];
+ p->ufd=stdout;
+ p->useek=canseek(stdout);
+ /* IOLBUF and setvbuf only in system 5+ */
+#ifdef COMMENTED_OUT
+ if(isatty(fileno(stdout))) {
+ extern char _sobuf[];
+ setbuf(stdout, _sobuf);
+ /* setvbuf(stdout, _IOLBF, 0, 0); /* the buf arg in setvbuf? */
+ p->useek = 1; /* only within a record no bigger than BUFSIZ */
+ }
+#endif
+ p->ufmt=1;
+ p->uwrt=1;
+}
+canseek(f) FILE *f; /*SYSDEP*/
+{
+#ifdef MSDOS
+ return !isatty(fileno(f));
+#else
+ struct stat x;
+
+ if (fstat(fileno(f),&x) < 0)
+ return(0);
+#ifdef S_IFMT
+ switch(x.st_mode & S_IFMT) {
+ case S_IFDIR:
+ case S_IFREG:
+ if(x.st_nlink > 0) /* !pipe */
+ return(1);
+ else
+ return(0);
+ case S_IFCHR:
+ if(isatty(fileno(f)))
+ return(0);
+ return(1);
+#ifdef S_IFBLK
+ case S_IFBLK:
+ return(1);
+#endif
+ }
+#else
+#ifdef S_ISDIR
+ /* POSIX version */
+ if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) {
+ if(x.st_nlink > 0) /* !pipe */
+ return(1);
+ else
+ return(0);
+ }
+ if (S_ISCHR(x.st_mode)) {
+ if(isatty(fileno(f)))
+ return(0);
+ return(1);
+ }
+ if (S_ISBLK(x.st_mode))
+ return(1);
+#else
+ Help! How does fstat work on this system?
+#endif
+#endif
+ return(0); /* who knows what it is? */
+#endif
+}
+nowreading(x) unit *x;
+{
+ long loc;
+ extern char *r_mode[];
+ if (!x->ufnm)
+ goto cantread;
+ loc=ftell(x->ufd);
+ if(freopen(x->ufnm,r_mode[x->ufmt],x->ufd) == NULL) {
+ cantread:
+ errno = 126;
+ return(1);
+ }
+ x->uwrt=0;
+ (void) fseek(x->ufd,loc,SEEK_SET);
+ return(0);
+}
+nowwriting(x) unit *x;
+{
+ long loc;
+ int k;
+ extern char *w_mode[];
+
+ if (!x->ufnm)
+ goto cantwrite;
+ if (x->uwrt == 3) { /* just did write, rewind */
+ if (close(creat(x->ufnm,0666)))
+ goto cantwrite;
+ }
+ else {
+ loc=ftell(x->ufd);
+ if (fclose(x->ufd) < 0
+ || (k = x->uwrt == 2 ? creat(x->ufnm,0666)
+ : open(x->ufnm,O_WRONLY)) < 0
+ || (cf = x->ufd = fdopen(k,w_mode[x->ufmt])) == NULL) {
+ x->ufd = NULL;
+ cantwrite:
+ errno = 127;
+ return(1);
+ }
+ (void) fseek(x->ufd,loc,SEEK_SET);
+ }
+ x->uwrt = 1;
+ return(0);
+}
--- /dev/null
+#include "stdio.h"
+#ifndef NULL
+/* ANSI C */
+#include "stddef.h"
+#endif
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#define SEEK_CUR 1
+#define SEEK_END 2
+#endif
+
+#ifdef MSDOS
+#ifndef NON_UNIX_STDIO
+#define NON_UNIX_STDIO
+#endif
+#endif
+
+/*units*/
+typedef struct
+{ FILE *ufd; /*0=unconnected*/
+ char *ufnm;
+#ifndef MSDOS
+ long uinode;
+ int udev;
+#endif
+ int url; /*0=sequential*/
+ flag useek; /*true=can backspace, use dir, ...*/
+ flag ufmt;
+ flag uprnt;
+ flag ublnk;
+ flag uend;
+ flag uwrt; /*last io was write*/
+ flag uscrtch;
+} unit;
+
+extern int errno;
+extern flag init;
+extern cilist *elist; /*active external io list*/
+extern flag reading,external,sequential,formatted;
+extern int (*getn)(),(*putn)(); /*for formatted io*/
+extern long inode();
+extern FILE *cf; /*current file*/
+extern unit *curunit; /*current unit*/
+extern unit units[];
+extern VOID sig_die();
+#define err(f,m,s) {if(f) errno= m; else fatal(m,s); return(m);}
+
+/*Table sizes*/
+#define MXUNIT 100
+
+extern int recpos; /*position in current record*/
+extern int cursor; /* offset to move to */
+extern int hiwater; /* so TL doesn't confuse us */
+
+#define WRITE 1
+#define READ 2
+#define SEQ 3
+#define DIR 4
+#define FMT 5
+#define UNF 6
+#define EXT 7
+#define INT 8
+
+#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#define skip(s) while(*s==' ') s++
+#ifdef interdata
+#define SYLMX 300
+#endif
+#ifdef pdp11
+#define SYLMX 300
+#endif
+#ifdef vax
+#define SYLMX 300
+#endif
+#ifndef SYLMX
+#define SYLMX 300
+#endif
+#define GLITCH '\2'
+ /* special quote character for stu */
+extern int cursor,scale;
+extern flag cblank,cplus; /*blanks in I and compulsory plus*/
+struct syl syl[SYLMX];
+int parenlvl,pc,revloc;
+
+char *f_s(),*f_list(),*i_tem(),*gt_num();
+
+pars_f(s) char *s;
+{
+ parenlvl=revloc=pc=0;
+ if(f_s(s,0) == NULL)
+ {
+ return(-1);
+ }
+ return(0);
+}
+char *f_s(s,curloc) char *s;
+{
+ skip(s);
+ if(*s++!='(')
+ {
+ return(NULL);
+ }
+ if(parenlvl++ ==1) revloc=curloc;
+ if(op_gen(RET,curloc,0,0)<0 ||
+ (s=f_list(s))==NULL)
+ {
+ return(NULL);
+ }
+ skip(s);
+ return(s);
+}
+char *f_list(s) char *s;
+{
+ for(;*s!=0;)
+ { skip(s);
+ if((s=i_tem(s))==NULL) return(NULL);
+ skip(s);
+ if(*s==',') s++;
+ else if(*s==')')
+ { if(--parenlvl==0)
+ {
+ (void) op_gen(REVERT,revloc,0,0);
+ return(++s);
+ }
+ (void) op_gen(GOTO,0,0,0);
+ return(++s);
+ }
+ }
+ return(NULL);
+}
+char *i_tem(s) char *s;
+{ char *t;
+ int n,curloc;
+ if(*s==')') return(s);
+ if(ne_d(s,&t)) return(t);
+ if(e_d(s,&t)) return(t);
+ s=gt_num(s,&n);
+ if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
+ return(f_s(s,curloc));
+}
+ne_d(s,p) char *s,**p;
+{ int n,x,sign=0;
+ char *ap_end();
+ struct syl *sp;
+ switch(*s)
+ {
+ default:
+ return(0);
+ case ':': (void) op_gen(COLON,0,0,0); break;
+ case '$':
+ (void) op_gen(NONL, 0, 0, 0); break;
+ case 'B':
+ case 'b':
+ if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
+ else (void) op_gen(BN,0,0,0);
+ break;
+ case 'S':
+ case 's':
+ if(*(s+1)=='s' || *(s+1) == 'S')
+ { x=SS;
+ s++;
+ }
+ else if(*(s+1)=='p' || *(s+1) == 'P')
+ { x=SP;
+ s++;
+ }
+ else x=S;
+ (void) op_gen(x,0,0,0);
+ break;
+ case '/': (void) op_gen(SLASH,0,0,0); break;
+ case '-': sign=1;
+ case '+': s++; /*OUTRAGEOUS CODING TRICK*/
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ s=gt_num(s,&n);
+ switch(*s)
+ {
+ default:
+ return(0);
+ case 'P':
+ case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
+ case 'X':
+ case 'x': (void) op_gen(X,n,0,0); break;
+ case 'H':
+ case 'h':
+ sp = &syl[op_gen(H,n,0,0)];
+ *(char **)&sp->p2 = s + 1;
+ s+=n;
+ break;
+ }
+ break;
+ case GLITCH:
+ case '"':
+ case '\'':
+ sp = &syl[op_gen(APOS,0,0,0)];
+ *(char **)&sp->p2 = s;
+ if((*p = ap_end(s)) == NULL)
+ return(0);
+ return(1);
+ case 'T':
+ case 't':
+ if(*(s+1)=='l' || *(s+1) == 'L')
+ { x=TL;
+ s++;
+ }
+ else if(*(s+1)=='r'|| *(s+1) == 'R')
+ { x=TR;
+ s++;
+ }
+ else x=T;
+ s=gt_num(s+1,&n);
+ s--;
+ (void) op_gen(x,n,0,0);
+ break;
+ case 'X':
+ case 'x': (void) op_gen(X,1,0,0); break;
+ case 'P':
+ case 'p': (void) op_gen(P,1,0,0); break;
+ }
+ s++;
+ *p=s;
+ return(1);
+}
+e_d(s,p) char *s,**p;
+{ int n,w,d,e,found=0,x=0;
+ char *sv=s;
+ s=gt_num(s,&n);
+ (void) op_gen(STACK,n,0,0);
+ switch(*s++)
+ {
+ default: break;
+ case 'E':
+ case 'e': x=1;
+ case 'G':
+ case 'g':
+ found=1;
+ s=gt_num(s,&w);
+ if(w==0) break;
+ if(*s=='.')
+ { s++;
+ s=gt_num(s,&d);
+ }
+ else d=0;
+ if(*s!='E' && *s != 'e')
+ (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */
+ else
+ { s++;
+ s=gt_num(s,&e);
+ (void) op_gen(x==1?EE:GE,w,d,e);
+ }
+ break;
+ case 'O':
+ case 'o':
+ found = 1;
+ s = gt_num(s, &w);
+ if(w==0) break;
+ (void) op_gen(O, w, 0, 0);
+ break;
+ case 'L':
+ case 'l':
+ found=1;
+ s=gt_num(s,&w);
+ if(w==0) break;
+ (void) op_gen(L,w,0,0);
+ break;
+ case 'A':
+ case 'a':
+ found=1;
+ skip(s);
+ if(*s>='0' && *s<='9')
+ { s=gt_num(s,&w);
+ if(w==0) break;
+ (void) op_gen(AW,w,0,0);
+ break;
+ }
+ (void) op_gen(A,0,0,0);
+ break;
+ case 'F':
+ case 'f':
+ found=1;
+ s=gt_num(s,&w);
+ if(w==0) break;
+ if(*s=='.')
+ { s++;
+ s=gt_num(s,&d);
+ }
+ else d=0;
+ (void) op_gen(F,w,d,0);
+ break;
+ case 'D':
+ case 'd':
+ found=1;
+ s=gt_num(s,&w);
+ if(w==0) break;
+ if(*s=='.')
+ { s++;
+ s=gt_num(s,&d);
+ }
+ else d=0;
+ (void) op_gen(D,w,d,0);
+ break;
+ case 'I':
+ case 'i':
+ found=1;
+ s=gt_num(s,&w);
+ if(w==0) break;
+ if(*s!='.')
+ { (void) op_gen(I,w,0,0);
+ break;
+ }
+ s++;
+ s=gt_num(s,&d);
+ (void) op_gen(IM,w,d,0);
+ break;
+ }
+ if(found==0)
+ { pc--; /*unSTACK*/
+ *p=sv;
+ return(0);
+ }
+ *p=s;
+ return(1);
+}
+op_gen(a,b,c,d)
+{ struct syl *p= &syl[pc];
+ if(pc>=SYLMX)
+ { fprintf(stderr,"format too complicated:\n");
+ sig_die(fmtbuf, 1);
+ }
+ p->op=a;
+ p->p1=b;
+ p->p2=c;
+ p->p3=d;
+ return(pc++);
+}
+char *gt_num(s,n) char *s; int *n;
+{ int m=0,cnt=0;
+ char c;
+ for(c= *s;;c = *s)
+ { if(c==' ')
+ { s++;
+ continue;
+ }
+ if(c>'9' || c<'0') break;
+ m=10*m+c-'0';
+ cnt++;
+ s++;
+ }
+ if(cnt==0) *n=1;
+ else *n=m;
+ return(s);
+}
+#define STKSZ 10
+int cnt[STKSZ],ret[STKSZ],cp,rp;
+flag workdone, nonl;
+
+integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+{ struct syl *p;
+ int n,i;
+ for(i=0;i<*number;i++,ptr+=len)
+ {
+loop: switch(type_f((p= &syl[pc])->op))
+ {
+ default:
+ fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
+ p->op,fmtbuf);
+ err(elist->cierr,100,"do_fio");
+ case NED:
+ if((*doned)(p))
+ { pc++;
+ goto loop;
+ }
+ pc++;
+ continue;
+ case ED:
+ if(cnt[cp]<=0)
+ { cp--;
+ pc++;
+ goto loop;
+ }
+ if(ptr==NULL)
+ return((*doend)());
+ cnt[cp]--;
+ workdone=1;
+ if((n=(*doed)(p,ptr,len))>0) err(elist->cierr,errno,"fmt");
+ if(n<0) err(elist->ciend,(EOF),"fmt");
+ continue;
+ case STACK:
+ cnt[++cp]=p->p1;
+ pc++;
+ goto loop;
+ case RET:
+ ret[++rp]=p->p1;
+ pc++;
+ goto loop;
+ case GOTO:
+ if(--cnt[cp]<=0)
+ { cp--;
+ rp--;
+ pc++;
+ goto loop;
+ }
+ pc=1+ret[rp--];
+ goto loop;
+ case REVERT:
+ rp=cp=0;
+ pc = p->p1;
+ if(ptr==NULL)
+ return((*doend)());
+ if(!workdone) return(0);
+ if((n=(*dorevert)()) != 0) return(n);
+ goto loop;
+ case COLON:
+ if(ptr==NULL)
+ return((*doend)());
+ pc++;
+ goto loop;
+ case NONL:
+ nonl = 1;
+ pc++;
+ goto loop;
+ case S:
+ case SS:
+ cplus=0;
+ pc++;
+ goto loop;
+ case SP:
+ cplus = 1;
+ pc++;
+ goto loop;
+ case P: scale=p->p1;
+ pc++;
+ goto loop;
+ case BN:
+ cblank=0;
+ pc++;
+ goto loop;
+ case BZ:
+ cblank=1;
+ pc++;
+ goto loop;
+ }
+ }
+ return(0);
+}
+en_fio()
+{ ftnint one=1;
+ return(do_fio(&one,(char *)NULL,(ftnint)0));
+}
+fmt_bg()
+{
+ workdone=cp=rp=pc=cursor=0;
+ cnt[0]=ret[0]=0;
+}
+type_f(n)
+{
+ switch(n)
+ {
+ default:
+ return(n);
+ case RET:
+ return(RET);
+ case REVERT: return(REVERT);
+ case GOTO: return(GOTO);
+ case STACK: return(STACK);
+ case X:
+ case SLASH:
+ case APOS: case H:
+ case T: case TL: case TR:
+ return(NED);
+ case F:
+ case I:
+ case IM:
+ case A: case AW:
+ case O:
+ case L:
+ case E: case EE: case D:
+ case G: case GE:
+ return(ED);
+ }
+}
+char *ap_end(s) char *s;
+{ char quote;
+ quote= *s++;
+ for(;*s;s++)
+ { if(*s!=quote) continue;
+ if(*++s!=quote) return(s);
+ }
+ if(elist->cierr) {
+ errno = 100;
+ return(NULL);
+ }
+ fatal(100, "bad string");
+ /*NOTREACHED*/ return 0;
+}
--- /dev/null
+struct syl
+{ int op,p1,p2,p3;
+};
+#define RET 1
+#define REVERT 2
+#define GOTO 3
+#define X 4
+#define SLASH 5
+#define STACK 6
+#define I 7
+#define ED 8
+#define NED 9
+#define IM 10
+#define APOS 11
+#define H 12
+#define TL 13
+#define TR 14
+#define T 15
+#define COLON 16
+#define S 17
+#define SP 18
+#define SS 19
+#define P 20
+#define BN 21
+#define BZ 22
+#define F 23
+#define E 24
+#define EE 25
+#define D 26
+#define G 27
+#define GE 28
+#define L 29
+#define A 30
+#define AW 31
+#define O 32
+#define NONL 33
+extern struct syl syl[];
+extern int pc,parenlvl,revloc;
+extern int (*doed)(),(*doned)();
+extern int (*dorevert)(),(*donewrec)(),(*doend)();
+extern flag cblank,cplus,workdone, nonl;
+extern int dummy();
+extern char *fmtbuf;
+extern int scale;
+typedef union
+{ real pf;
+ doublereal pd;
+} ufloat;
+typedef union
+{ short is;
+ char ic;
+ long il;
+} uint;
+#define GET(x) if((x=(*getn)())<0) return(x)
+#define VAL(x) (x!='\n'?x:' ')
+#define PUT(x) (*putn)(x)
+extern int cursor;
--- /dev/null
+/* @(#)fmtlib.c 1.2 */
+#define MAXINTLENGTH 23
+char *icvt(value,ndigit,sign, base) long value; int *ndigit,*sign;
+register int base;
+{ static char buf[MAXINTLENGTH+1];
+ register int i;
+ if(value>0) *sign=0;
+ else if(value<0)
+ { value = -value;
+ *sign= 1;
+ }
+ else
+ { *sign=0;
+ *ndigit=1;
+ buf[MAXINTLENGTH]='0';
+ return(&buf[MAXINTLENGTH]);
+ }
+ for(i=MAXINTLENGTH-1;value>0;i--)
+ { *(buf+i)=(int)(value%base)+'0';
+ value /= base;
+ }
+ *ndigit=MAXINTLENGTH-1-i;
+ return(&buf[i+1]);
+}
--- /dev/null
+#define FMAX 40
+#define EXPMAXDIGS 8
+#define EXPMAX 99999999
+/* FMAX = max number of nonzero digits passed to atof() */
+/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */
+
+#include "local.h"
+
+/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily
+ tight) on the maximum number of digits to the right and left of
+ * the decimal point.
+ */
+
+#ifdef VAX
+#define MAXFRACDIGS 56
+#define MAXINTDIGS 38
+#else
+#ifdef CRAY
+#define MAXFRACDIGS 9880
+#define MAXINTDIGS 9864
+#else
+/* values that suffice for IEEE double */
+#define MAXFRACDIGS 344
+#define MAXINTDIGS 308
+#endif
+#endif
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+extern char *icptr;
+char *icend;
+extern icilist *svic;
+extern int rd_ed(),rd_ned(),w_ed(),w_ned(),y_ierr();
+extern int z_wnew();
+int icnum;
+extern int hiwater;
+z_getc()
+{
+ if(icptr >= icend) err(svic->iciend,(EOF),"endfile");
+ if(recpos++ < svic->icirlen)
+ return(*icptr++);
+ else err(svic->icierr,110,"recend");
+}
+z_putc(c)
+{
+ if(icptr >= icend) err(svic->icierr,110,"inwrite");
+ if(recpos++ < svic->icirlen)
+ *icptr++ = c;
+ else err(svic->icierr,110,"recend");
+ return 0;
+}
+z_rnew()
+{
+ icptr = svic->iciunit + (++icnum)*svic->icirlen;
+ recpos = 0;
+ cursor = 0;
+ hiwater = 0;
+ return 1;
+}
+
+ static int
+z_endp(a) icilist *a;
+{
+ (*donewrec)();
+ return 0;
+ }
+
+integer s_rsfi(a) icilist *a;
+{ int n;
+ if(n=c_si(a)) return(n);
+ reading=1;
+ doed=rd_ed;
+ doned=rd_ned;
+ getn=z_getc;
+ dorevert = y_ierr;
+ donewrec = z_rnew;
+ doend = z_endp;
+ return(0);
+}
+
+integer s_wsfi(a) icilist *a;
+{ int n;
+ if(n=c_si(a)) return(n);
+ reading=0;
+ doed=w_ed;
+ doned=w_ned;
+ putn=z_putc;
+ dorevert = y_ierr;
+ donewrec = z_wnew;
+ doend = z_endp;
+ return(0);
+}
+c_si(a) icilist *a;
+{
+ elist = (cilist *)a;
+ fmtbuf=a->icifmt;
+ if(pars_f(fmtbuf)<0)
+ err(a->icierr,100,"startint");
+ fmt_bg();
+ sequential=formatted=1;
+ external=0;
+ cblank=cplus=scale=0;
+ svic=a;
+ icnum=recpos=0;
+ cursor = 0;
+ hiwater = 0;
+ icptr = a->iciunit;
+ icend = icptr + a->icirlen*a->icirnum;
+ curunit = 0;
+ return(0);
+}
+z_wnew()
+{
+ while(recpos++ < svic->icirlen)
+ *icptr++ = ' ';
+ recpos = 0;
+ cursor = 0;
+ hiwater = 0;
+ icnum++;
+ return 1;
+}
+integer e_rsfi()
+{ int n;
+ n = en_fio();
+ fmtbuf = NULL;
+ return(n);
+}
+integer e_wsfi()
+{
+ int n;
+ n = en_fio();
+ fmtbuf = NULL;
+ if(icnum >= svic->icirnum)
+ return(n);
+ while(recpos++ < svic->icirlen)
+ *icptr++ = ' ';
+ return(n);
+}
+y_ierr()
+{
+ err(elist->cierr, 110, "iio");
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+extern char *icptr;
+extern char *icend;
+extern icilist *svic;
+extern int icnum;
+extern int (*donewrec)();
+extern int z_putc(), l_write();
+
+ static int
+z_wSL()
+{
+ extern int z_rnew();
+ while(recpos < svic->icirlen)
+ z_putc(' ');
+ return z_rnew();
+ }
+
+ int
+c_liw(a)
+ icilist *a;
+{
+ reading = 0;
+ external = 0;
+ formatted = 1;
+ putn = z_putc;
+ L_len = a->icirlen;
+ donewrec = z_wSL;
+ svic = a;
+ icnum = recpos = 0;
+ cursor = 0;
+ cf = 0;
+ curunit = 0;
+ icptr = a->iciunit;
+ icend = icptr + a->icirlen*a->icirnum;
+ }
+
+s_wsni(a)
+ icilist *a;
+{
+ cilist ca;
+
+ c_liw(a);
+ ca.cifmt = a->icifmt;
+ x_wsne(&ca);
+ z_wSL();
+ return 0;
+ }
+
+integer s_wsli(a) icilist *a;
+{
+ lioproc = l_write;
+ c_liw(a);
+ return(0);
+ }
+
+integer e_wsli()
+{
+ z_wSL();
+ return(0);
+ }
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+integer f_inqu(a) inlist *a;
+{ flag byfile;
+ int i, n;
+ unit *p;
+ char buf[256];
+ long x;
+ if(a->infile!=NULL)
+ { byfile=1;
+ g_char(a->infile,a->infilen,buf);
+#ifdef MSDOS
+ x = access(buf,0) ? -1 : 0;
+ for(i=0,p=NULL;i<MXUNIT;i++)
+ if(units[i].ufd!=NULL && !strcmp(units[i].ufnm,buf)) {
+ p = &units[i];
+ break;
+ }
+#else
+ x=inode(buf, &n);
+ for(i=0,p=NULL;i<MXUNIT;i++)
+ if(units[i].uinode==x
+ && units[i].ufd!=NULL
+ && units[i].udev == n) {
+ p = &units[i];
+ break;
+ }
+#endif
+ }
+ else
+ {
+ byfile=0;
+ if(a->inunit<MXUNIT && a->inunit>=0)
+ {
+ p= &units[a->inunit];
+ }
+ else
+ {
+ p=NULL;
+ }
+ }
+ if(a->inex!=NULL)
+ if(byfile && x != -1 || !byfile && p!=NULL)
+ *a->inex=1;
+ else *a->inex=0;
+ if(a->inopen!=NULL)
+ if(byfile) *a->inopen=(p!=NULL);
+ else *a->inopen=(p!=NULL && p->ufd!=NULL);
+ if(a->innum!=NULL) *a->innum= p-units;
+ if(a->innamed!=NULL)
+ if(byfile || p!=NULL && p->ufnm!=NULL)
+ *a->innamed=1;
+ else *a->innamed=0;
+ if(a->inname!=NULL)
+ if(byfile)
+ b_char(buf,a->inname,a->innamlen);
+ else if(p!=NULL && p->ufnm!=NULL)
+ b_char(p->ufnm,a->inname,a->innamlen);
+ if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
+ if(p->url)
+ b_char("DIRECT",a->inacc,a->inacclen);
+ else b_char("SEQUENTIAL",a->inacc,a->inacclen);
+ if(a->inseq!=NULL)
+ if(p!=NULL && p->url)
+ b_char("NO",a->inseq,a->inseqlen);
+ else b_char("YES",a->inseq,a->inseqlen);
+ if(a->indir!=NULL)
+ if(p==NULL || p->url)
+ b_char("YES",a->indir,a->indirlen);
+ else b_char("NO",a->indir,a->indirlen);
+ if(a->infmt!=NULL)
+ if(p!=NULL && p->ufmt==0)
+ b_char("UNFORMATTED",a->infmt,a->infmtlen);
+ else b_char("FORMATTED",a->infmt,a->infmtlen);
+ if(a->inform!=NULL)
+ if(p!=NULL && p->ufmt==0)
+ b_char("NO",a->inform,a->informlen);
+ else b_char("YES",a->inform,a->informlen);
+ if(a->inunf)
+ if(p!=NULL && p->ufmt==0)
+ b_char("YES",a->inunf,a->inunflen);
+ else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
+ else b_char("UNKNOWN",a->inunf,a->inunflen);
+ if(a->inrecl!=NULL && p!=NULL)
+ *a->inrecl=p->url;
+ if(a->innrec!=NULL && p!=NULL && p->url>0)
+ *a->innrec=ftell(p->ufd)/p->url+1;
+ if(a->inblank && p!=NULL && p->ufmt)
+ if(p->ublnk)
+ b_char("ZERO",a->inblank,a->inblanklen);
+ else b_char("NULL",a->inblank,a->inblanklen);
+ return(0);
+}
--- /dev/null
+Notice fb5a412e 1183
+README 11f3b057 3861
+Version.c f5466c95 3906
+backspace.c 1fb89c72 1252
+close.c f5b0a34 903
+dfe.c f79d0dc0 2463
+dolio.c 182d4c60 171
+due.c e969b824 1157
+endfile.c ef355044 1565
+err.c bbc2455 5270
+fio.h ff0cdf36 1289
+fmt.c f10c2693 6872
+fmt.h 464603c 960
+fmtlib.c 19f5bfc7 487
+fp.h 8d2c32e 613
+iio.c f93e1289 1827
+ilnw.c a849740 799
+inquire.c 86dbf5e 2313
+lio.h f14b794d 763
+lread.c fb8ef2ac 9054
+lwrite.c f133d18b 2392
+makefile f98cddc3 1819
+open.c a131d7e 3573
+rdfmt.c f6daa35f 5703
+rewind.c f9aac3ab 350
+rsfe.c fcfa2e1f 1175
+rsli.c fb196d1 1249
+rsne.c 12ba3382 8392
+sfe.c ef16283a 555
+sue.c 8ba8875 1420
+typesize.c f31c8492 197
+uio.c f12544cd 906
+util.c ebe8973 1036
+wref.c 65fbc97 3632
+wrtfmt.c e77eafc 5358
+wsfe.c cbef67 1540
+wsle.c 8622874 552
+wsne.c 1d6ff5 435
+xwsne.c fab6cba6 882
--- /dev/null
+/* copy of ftypes from the compiler */
+/* variable types
+ * numeric assumptions:
+ * int < reals < complexes
+ * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYSHORT 2
+#define TYLONG 3
+#define TYREAL 4
+#define TYDREAL 5
+#define TYCOMPLEX 6
+#define TYDCOMPLEX 7
+#define TYLOGICAL 8
+#define TYCHAR 9
+#define TYSUBR 10
+#define TYERROR 11
+
+#define NTYPES (TYERROR+1)
+
+#define LINTW 12
+#define LINE 80
+#define LLOGW 2
+#define LLOW 1.0
+#define LHIGH 1.e9
+#define LEFMT " %# .8E"
+#define LFFMT " %# .9g"
+/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */
+#define LEFBL 24
+
+typedef union
+{ short flshort;
+ ftnint flint;
+ real flreal;
+ doublereal fldouble;
+} flex;
+extern int scale;
+extern int (*lioproc)();
+extern int L_len;
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "lio.h"
+#include "ctype.h"
+#include "fp.h"
+
+extern char *fmtbuf;
+extern char *malloc(), *realloc();
+int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
+int l_eof;
+
+#define isblnk(x) (ltab[x+1]&B)
+#define issep(x) (ltab[x+1]&SX)
+#define isapos(x) (ltab[x+1]&AX)
+#define isexp(x) (ltab[x+1]&EX)
+#define issign(x) (ltab[x+1]&SG)
+#define iswhit(x) (ltab[x+1]&WH)
+#define SX 1
+#define B 2
+#define AX 4
+#define EX 8
+#define SG 16
+#define WH 32
+char ltab[128+1] = { /* offset one for EOF */
+ 0,
+ 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
+};
+
+t_getc()
+{ int ch;
+ if(curunit->uend) return(EOF);
+ if((ch=getc(cf))!=EOF) return(ch);
+ if(feof(cf))
+ l_eof = curunit->uend = 1;
+ return(EOF);
+}
+integer e_rsle()
+{
+ int ch;
+ if(curunit->uend) return(0);
+ while((ch=t_getc())!='\n' && ch!=EOF);
+ return(0);
+}
+
+flag lquit;
+int lcount,ltype;
+char *lchar;
+double lx,ly;
+#define ERR(x) if(n=(x)) return(n)
+#define GETC(x) (x=(*l_getc)())
+#define Ungetc(x,y) (*l_ungetc)(x,y)
+
+l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
+{
+#define Ptr ((flex *)ptr)
+ int i,n,ch;
+ doublereal *yy;
+ real *xx;
+ for(i=0;i<*number;i++)
+ {
+ if(lquit) return(0);
+ if(l_eof)
+ err(elist->ciend, EOF, "list in")
+ if(lcount == 0) {
+ ltype = 0;
+ for(;;) {
+ GETC(ch);
+ switch(ch) {
+ case EOF:
+ goto loopend;
+ case ' ':
+ case '\t':
+ case '\n':
+ continue;
+ case '/':
+ lquit = 1;
+ goto loopend;
+ case ',':
+ lcount = 1;
+ goto loopend;
+ default:
+ (void) Ungetc(ch, cf);
+ goto rddata;
+ }
+ }
+ }
+ rddata:
+ switch((int)type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ case TYREAL:
+ case TYDREAL:
+ ERR(l_R(0));
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ ERR(l_C());
+ break;
+ case TYLOGICAL:
+ ERR(l_L());
+ break;
+ case TYCHAR:
+ ERR(l_CHAR());
+ break;
+ }
+ while (GETC(ch) == ' ' || ch == '\t');
+ if (ch != ',')
+ Ungetc(ch,cf);
+ loopend:
+ if(lquit) return(0);
+ if(cf) {
+ if (feof(cf))
+ err(elist->ciend,(EOF),"list in")
+ else if(ferror(cf)) {
+ clearerr(cf);
+ err(elist->cierr,errno,"list in")
+ }
+ }
+ if(ltype==0) goto bump;
+ switch((int)type)
+ {
+ case TYSHORT:
+ Ptr->flshort=lx;
+ break;
+ case TYLOGICAL:
+ case TYLONG:
+ Ptr->flint=lx;
+ break;
+ case TYREAL:
+ Ptr->flreal=lx;
+ break;
+ case TYDREAL:
+ Ptr->fldouble=lx;
+ break;
+ case TYCOMPLEX:
+ xx=(real *)ptr;
+ *xx++ = lx;
+ *xx = ly;
+ break;
+ case TYDCOMPLEX:
+ yy=(doublereal *)ptr;
+ *yy++ = lx;
+ *yy = ly;
+ break;
+ case TYCHAR:
+ b_char(lchar,ptr,len);
+ break;
+ }
+ bump:
+ if(lcount>0) lcount--;
+ ptr += len;
+ }
+ return(0);
+#undef Ptr
+}
+l_R(poststar)
+ int poststar;
+{
+ char s[FMAX+EXPMAXDIGS+4];
+ register int ch;
+ register char *sp, *spe, *sp1;
+ long e, exp;
+ double atof();
+ int havenum, se;
+
+ if (!poststar) {
+ if (lcount > 0)
+ return(0);
+ lcount = 1;
+ }
+ ltype = 0;
+ exp = 0;
+retry:
+ sp1 = sp = s;
+ spe = sp + FMAX;
+ havenum = 0;
+
+ switch(GETC(ch)) {
+ case '-': *sp++ = ch; sp1++; spe++;
+ case '+':
+ GETC(ch);
+ }
+ while(ch == '0') {
+ ++havenum;
+ GETC(ch);
+ }
+ while(isdigit(ch)) {
+ if (sp < spe) *sp++ = ch;
+ else ++exp;
+ GETC(ch);
+ }
+ if (ch == '*' && !poststar) {
+ if (sp == sp1 || exp || *s == '-') {
+ err(elist->cierr,112,"bad repetition count")
+ }
+ poststar = 1;
+ *sp = 0;
+ lcount = atoi(s);
+ goto retry;
+ }
+ if (ch == '.') {
+ GETC(ch);
+ if (sp == sp1)
+ while(ch == '0') {
+ ++havenum;
+ --exp;
+ GETC(ch);
+ }
+ while(isdigit(ch)) {
+ if (sp < spe)
+ { *sp++ = ch; --exp; }
+ GETC(ch);
+ }
+ }
+ se = 0;
+ if (issign(ch))
+ goto signonly;
+ if (isexp(ch)) {
+ GETC(ch);
+ if (issign(ch)) {
+signonly:
+ if (ch == '-') se = 1;
+ GETC(ch);
+ }
+ if (!isdigit(ch)) {
+bad:
+ err(elist->cierr,112,"exponent field")
+ }
+
+ e = ch - '0';
+ while(isdigit(GETC(ch))) {
+ e = 10*e + ch - '0';
+ if (e > EXPMAX)
+ goto bad;
+ }
+ if (se)
+ exp -= e;
+ else
+ exp += e;
+ }
+ (void) Ungetc(ch, cf);
+ if (sp > sp1) {
+ ++havenum;
+ while(*--sp == '0')
+ ++exp;
+ if (exp)
+ sprintf(sp+1, "e%ld", exp);
+ else
+ sp[1] = 0;
+ lx = atof(s);
+ }
+ else
+ lx = 0.;
+ if (havenum)
+ ltype = TYLONG;
+ else
+ switch(ch) {
+ case ',':
+ case '/':
+ break;
+ default:
+ err(elist->cierr,112,"invalid number")
+ }
+ return 0;
+ }
+
+ static int
+rd_count(ch)
+ register int ch;
+{
+ if (ch < '0' || ch > '9')
+ return 1;
+ lcount = ch - '0';
+ while(GETC(ch) >= '0' && ch <= '9')
+ lcount = 10*lcount + ch - '0';
+ Ungetc(ch,cf);
+ return 0;
+ }
+
+l_C()
+{ int ch;
+ double lz;
+ if(lcount>0) return(0);
+ ltype=0;
+ GETC(ch);
+ if(ch!='(')
+ {
+ if (rd_count(ch))
+ if(!cf || !feof(cf))
+ err(elist->cierr,112,"complex format")
+ else
+ err(elist->cierr,(EOF),"lread");
+ if(GETC(ch)!='*')
+ {
+ if(!cf || !feof(cf))
+ err(elist->cierr,112,"no star")
+ else
+ err(elist->cierr,(EOF),"lread");
+ }
+ if(GETC(ch)!='(')
+ { (void) Ungetc(ch,cf);
+ return(0);
+ }
+ }
+ else
+ lcount = 1;
+ while(iswhit(GETC(ch)));
+ (void) Ungetc(ch,cf);
+ if (ch = l_R(1))
+ return ch;
+ if (!ltype)
+ err(elist->cierr,112,"no real part");
+ lz = lx;
+ while(iswhit(GETC(ch)));
+ if(ch!=',')
+ { (void) Ungetc(ch,cf);
+ err(elist->cierr,112,"no comma");
+ }
+ while(iswhit(GETC(ch)));
+ (void) Ungetc(ch,cf);
+ if (ch = l_R(1))
+ return ch;
+ if (!ltype)
+ err(elist->cierr,112,"no imaginary part");
+ while(iswhit(GETC(ch)));
+ if(ch!=')') err(elist->cierr,112,"no )");
+ ly = lx;
+ lx = lz;
+ return(0);
+}
+l_L()
+{
+ int ch;
+ if(lcount>0) return(0);
+ ltype=0;
+ GETC(ch);
+ if(isdigit(ch))
+ {
+ rd_count(ch);
+ if(GETC(ch)!='*')
+ if(!cf || !feof(cf))
+ err(elist->cierr,112,"no star")
+ else
+ err(elist->cierr,(EOF),"lread");
+ GETC(ch);
+ }
+ if(ch == '.') GETC(ch);
+ switch(ch)
+ {
+ case 't':
+ case 'T':
+ lx=1;
+ break;
+ case 'f':
+ case 'F':
+ lx=0;
+ break;
+ default:
+ if(isblnk(ch) || issep(ch) || ch==EOF)
+ { (void) Ungetc(ch,cf);
+ return(0);
+ }
+ else err(elist->cierr,112,"logical");
+ }
+ ltype=TYLONG;
+ lcount = 1;
+ while(!issep(GETC(ch)) && ch!=EOF);
+ (void) Ungetc(ch, cf);
+ return(0);
+}
+#define BUFSIZE 128
+l_CHAR()
+{ int ch,size,i;
+ char quote,*p;
+ if(lcount>0) return(0);
+ ltype=0;
+ if(lchar!=NULL) free(lchar);
+ size=BUFSIZE;
+ p=lchar=malloc((unsigned int)size);
+ if(lchar==NULL) err(elist->cierr,113,"no space");
+
+ GETC(ch);
+ if(isdigit(ch)) {
+ /* allow Fortran 8x-style unquoted string... */
+ /* either find a repetition count or the string */
+ lcount = ch - '0';
+ *p++ = ch;
+ for(i = 1;;) {
+ switch(GETC(ch)) {
+ case '*':
+ if (lcount == 0) {
+ lcount = 1;
+ goto noquote;
+ }
+ p = lchar;
+ goto have_lcount;
+ case ',':
+ case ' ':
+ case '\t':
+ case '\n':
+ case '/':
+ Ungetc(ch,cf);
+ /* no break */
+ case EOF:
+ lcount = 1;
+ ltype = TYCHAR;
+ return *p = 0;
+ }
+ if (!isdigit(ch)) {
+ lcount = 1;
+ goto noquote;
+ }
+ *p++ = ch;
+ lcount = 10*lcount + ch - '0';
+ if (++i == size) {
+ lchar = realloc(lchar,
+ (unsigned int)(size += BUFSIZE));
+ p = lchar + i;
+ }
+ }
+ }
+ else (void) Ungetc(ch,cf);
+ have_lcount:
+ if(GETC(ch)=='\'' || ch=='"') quote=ch;
+ else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
+ { (void) Ungetc(ch,cf);
+ return(0);
+ }
+ else {
+ /* Fortran 8x-style unquoted string */
+ *p++ = ch;
+ for(i = 1;;) {
+ switch(GETC(ch)) {
+ case ',':
+ case ' ':
+ case '\t':
+ case '\n':
+ case '/':
+ Ungetc(ch,cf);
+ /* no break */
+ case EOF:
+ ltype = TYCHAR;
+ return *p = 0;
+ }
+ noquote:
+ *p++ = ch;
+ if (++i == size) {
+ lchar = realloc(lchar,
+ (unsigned int)(size += BUFSIZE));
+ p = lchar + i;
+ }
+ }
+ }
+ ltype=TYCHAR;
+ for(i=0;;)
+ { while(GETC(ch)!=quote && ch!='\n'
+ && ch!=EOF && ++i<size) *p++ = ch;
+ if(i==size)
+ {
+ newone:
+ lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
+ p=lchar+i-1;
+ *p++ = ch;
+ }
+ else if(ch==EOF) return(EOF);
+ else if(ch=='\n')
+ { if(*(p-1) != '\\') continue;
+ i--;
+ p--;
+ if(++i<size) *p++ = ch;
+ else goto newone;
+ }
+ else if(GETC(ch)==quote)
+ { if(++i<size) *p++ = ch;
+ else goto newone;
+ }
+ else
+ { (void) Ungetc(ch,cf);
+ *p = 0;
+ return(0);
+ }
+ }
+}
+integer s_rsle(a) cilist *a;
+{
+ int n;
+ extern int ungetc();
+
+ if(!init) f_init();
+ if(n=c_le(a)) return(n);
+ reading=1;
+ external=1;
+ formatted=1;
+ lioproc = l_read;
+ lquit = 0;
+ lcount = 0;
+ l_eof = 0;
+ if(curunit->uwrt && nowreading(curunit))
+ err(a->cierr,errno,"read start");
+ l_getc = t_getc;
+ l_ungetc = ungetc;
+ return(0);
+}
+c_le(a) cilist *a;
+{
+ fmtbuf="list io";
+ if(a->ciunit>=MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"stler");
+ scale=recpos=0;
+ elist=a;
+ curunit = &units[a->ciunit];
+ if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
+ err(a->cierr,102,"lio");
+ cf=curunit->ufd;
+ if(!curunit->ufmt) err(a->cierr,103,"lio")
+ return(0);
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "lio.h"
+int L_len;
+
+t_putc(c)
+{
+ recpos++;
+ putc(c,cf);
+ return(0);
+}
+lwrt_I(n) ftnint n;
+{
+ char buf[LINTW],*p;
+#ifdef USE_STRLEN
+ (void) sprintf(buf," %ld",(long)n);
+ if(recpos+strlen(buf)>=L_len)
+#else
+ if(recpos + sprintf(buf," %ld",(long)n) >= L_len)
+#endif
+ (*donewrec)();
+ for(p=buf;*p;PUT(*p++));
+}
+lwrt_L(n, len) ftnint n; ftnlen len;
+{
+ if(recpos+LLOGW>=L_len)
+ (*donewrec)();
+ (void) wrt_L((uint *)&n,LLOGW, len);
+}
+lwrt_A(p,len) char *p; ftnlen len;
+{
+ int i;
+ if(recpos+len>=L_len)
+ (*donewrec)();
+ if (!recpos)
+ { PUT(' '); ++recpos; }
+ for(i=0;i<len;i++) PUT(*p++);
+}
+
+ static int
+l_g(buf, absn) char *buf; double absn;
+{
+ doublereal n;
+ char *fmt;
+
+ n = absn;
+ 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
+ }
+
+ static void
+l_put(s) register char *s;
+{
+ register int c, (*pn)() = putn;
+ while(c = *s++)
+ (*pn)(c);
+ }
+
+lwrt_F(n) double n;
+{
+ char buf[LEFBL];
+
+ if(recpos + l_g(buf,n) >= L_len)
+ (*donewrec)();
+ l_put(buf);
+}
+lwrt_C(a,b) double a,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(recpos + al + bl + 3 >= L_len && recpos)
+ (*donewrec)();
+ PUT(' ');
+ PUT('(');
+ l_put(ba);
+ PUT(',');
+ if (recpos + bl >= L_len) {
+ (*donewrec)();
+ PUT(' ');
+ }
+ l_put(bb);
+ PUT(')');
+}
+l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
+{
+#define Ptr ((flex *)ptr)
+ int i;
+ ftnint x;
+ double y,z;
+ real *xx;
+ doublereal *yy;
+ for(i=0;i< *number; i++)
+ {
+ switch((int)type)
+ {
+ default: fatal(204,"unknown type in lio");
+ case TYSHORT:
+ x=Ptr->flshort;
+ goto xint;
+ 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 TYLOGICAL:
+ lwrt_L(Ptr->flint, len);
+ break;
+ case TYCHAR:
+ lwrt_A(ptr,len);
+ break;
+ }
+ ptr += len;
+ }
+ return(0);
+}
--- /dev/null
+.SUFFIXES: .c .o
+
+CC = cc
+CFLAGS = -DSkip_f2c_Undefs -O
+SHELL = /bin/sh
+
+# compile, then strip unnecessary symbols
+.c.o:
+ $(CC) $(CFLAGS) -c $*.c
+ ld -r -x $*.o
+ mv a.out $*.o
+
+OBJ = Version.o backspace.o close.o dfe.o dolio.o due.o endfile.o err.o \
+ fmt.o fmtlib.o iio.o ilnw.o inquire.o lread.o lwrite.o open.o \
+ rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o uio.o \
+ util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o
+libI77.a: $(OBJ)
+ ar r libI77.a $?
+ ranlib libI77.a
+install: libI77.a
+ cp libI77.a /usr/lib/libI77.a
+ ranlib /usr/lib/libI77.a
+
+Version.o: Version.c
+ $(CC) -c Version.c
+
+
+clean:
+ rm -f $(OBJ) libI77.a
+
+clobber: clean
+ rm -f libI77.a
+
+backspace.o: fio.h
+close.o: fio.h
+dfe.o: fio.h
+dfe.o: fmt.h
+due.o: fio.h
+endfile.o: fio.h
+err.o: fio.h
+fmt.o: fio.h
+fmt.o: fmt.h
+iio.o: fio.h
+iio.o: fmt.h
+ilnw.o: fio.h
+ilnw.o: lio.h
+inquire.o: fio.h
+lread.o: fio.h
+lread.o: fmt.h
+lread.o: lio.h
+lread.o: fp.h
+lwrite.o: fio.h
+lwrite.o: fmt.h
+lwrite.o: lio.h
+open.o: fio.h
+rdfmt.o: fio.h
+rdfmt.o: fmt.h
+rdfmt.o: fp.h
+rewind.o: fio.h
+rsfe.o: fio.h
+rsfe.o: fmt.h
+rsli.o: fio.h
+rsli.o: lio.h
+rsne.o: fio.h
+rsne.o: lio.h
+sfe.o: fio.h
+sue.o: fio.h
+uio.o: fio.h
+util.o: fio.h
+wref.o: fio.h
+wref.o: fmt.h
+wref.o: fp.h
+wrtfmt.o: fio.h
+wrtfmt.o: fmt.h
+wsfe.o: fio.h
+wsfe.o: fmt.h
+wsle.o: fio.h
+wsle.o: fmt.h
+wsle.o: lio.h
+wsne.o: fio.h
+wsne.o: lio.h
+xwsne.o: fio.h
+xwsne.o: lio.h
+xwsne.o: fmt.h
+
+check:
+ xsum Notice README Version.c backspace.c close.c dfe.c dolio.c \
+ due.c endfile.c err.c fio.h fmt.c fmt.h fmtlib.c fp.h iio.c \
+ ilnw.c inquire.c lio.h lread.c lwrite.c makefile open.c \
+ rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c sue.c typesize.c \
+ uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c >zap
+ cmp zap libI77.xsum && rm zap || diff libI77.xsum zap
--- /dev/null
+#include "sys/types.h"
+#ifndef MSDOS
+#include "sys/stat.h"
+#endif
+#include "f2c.h"
+#include "fio.h"
+#include "string.h"
+#include "fcntl.h"
+#ifndef O_WRONLY
+#define O_RDONLY 0
+#define O_WRONLY 1
+#endif
+
+extern char *malloc(), *mktemp();
+extern FILE *fdopen();
+extern integer f_clos();
+#ifdef NON_ANSI_RW_MODES
+char *r_mode[2] = {"r", "r"};
+char *w_mode[2] = {"w", "w"};
+#else
+char *r_mode[2] = {"rb", "r"};
+char *w_mode[2] = {"wb", "w"};
+#endif
+
+integer f_open(a) olist *a;
+{ unit *b;
+ int n;
+ char buf[256];
+ cllist x;
+#ifndef MSDOS
+ struct stat stb;
+#endif
+ if(a->ounit>=MXUNIT || a->ounit<0)
+ err(a->oerr,101,"open")
+ curunit = b = &units[a->ounit];
+ if(b->ufd) {
+ if(a->ofnm==0)
+ {
+ same: if (a->oblnk)
+ b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
+ return(0);
+ }
+#ifdef MSDOS
+ if (b->ufnm
+ && strlen(b->ufnm) == a->ofnmlen
+ && !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen))
+ goto same;
+#else
+ g_char(a->ofnm,a->ofnmlen,buf);
+ if (inode(buf,&n) == b->uinode && n == b->udev)
+ goto same;
+#endif
+ x.cunit=a->ounit;
+ x.csta=0;
+ x.cerr=a->oerr;
+ if((n=f_clos(&x))!=0) return(n);
+ }
+ b->url=a->orl;
+ b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
+ if(a->ofm==0)
+ { if(b->url>0) b->ufmt=0;
+ else b->ufmt=1;
+ }
+ else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
+ else b->ufmt=0;
+#ifdef url_Adjust
+ if (b->url && !b->ufmt)
+ url_Adjust(b->url);
+#endif
+ if (a->ofnm) {
+ g_char(a->ofnm,a->ofnmlen,buf);
+ if (!buf[0])
+ err(a->oerr,107,"open")
+ }
+ else
+ sprintf(buf, "fort.%ld", a->ounit);
+ b->uscrtch = 0;
+ switch(a->osta ? *a->osta : 'u')
+ {
+ case 'o':
+ case 'O':
+#ifdef MSDOS
+ if(access(buf,0))
+#else
+ if(stat(buf,&stb))
+#endif
+ err(a->oerr,errno,"open")
+ break;
+ case 's':
+ case 'S':
+ b->uscrtch=1;
+ (void) strcpy(buf,"tmp.FXXXXXX");
+ (void) mktemp(buf);
+ (void) close(creat(buf, 0666));
+ break;
+ case 'n':
+ case 'N':
+#ifdef MSDOS
+ if(!access(buf,0))
+#else
+ if(!stat(buf,&stb))
+#endif
+ err(a->oerr,128,"open")
+ /* no break */
+ case 'r': /* Fortran 90 replace option */
+ case 'R':
+ (void) close(creat(buf, 0666));
+ break;
+ }
+
+ b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
+ if(b->ufnm==NULL) err(a->oerr,113,"no space");
+ (void) strcpy(b->ufnm,buf);
+ b->uend=0;
+ b->uwrt = 0;
+ if(isdev(buf))
+ { b->ufd = fopen(buf,r_mode[b->ufmt]);
+ if(b->ufd==NULL) err(a->oerr,errno,buf)
+ }
+ else {
+ if((b->ufd = fopen(buf, r_mode[b->ufmt])) == NULL) {
+ if ((n = open(buf,O_WRONLY)) >= 0) {
+ b->uwrt = 2;
+ }
+ else {
+ n = creat(buf, 0666);
+ b->uwrt = 1;
+ }
+ if (n < 0
+ || (b->ufd = fdopen(n, w_mode[b->ufmt])) == NULL)
+ err(a->oerr, errno, "open");
+ }
+ }
+ b->useek=canseek(b->ufd);
+#ifndef MSDOS
+ if((b->uinode=inode(buf,&b->udev))==-1)
+ err(a->oerr,108,"open")
+#endif
+ if(a->orl && b->useek) rewind(b->ufd);
+ return(0);
+}
+fk_open(seq,fmt,n) ftnint n;
+{ char nbuf[10];
+ olist a;
+ (void) sprintf(nbuf,"fort.%ld",n);
+ a.oerr=1;
+ a.ounit=n;
+ a.ofnm=nbuf;
+ a.ofnmlen=strlen(nbuf);
+ a.osta=NULL;
+ a.oacc= seq==SEQ?"s":"d";
+ a.ofm = fmt==FMT?"f":"u";
+ a.orl = seq==DIR?1:0;
+ a.oblnk=NULL;
+ return(f_open(&a));
+}
+isdev(s) char *s;
+{
+#ifdef MSDOS
+ int i, j;
+
+ i = open(s,O_RDONLY);
+ if (i == -1)
+ return 0;
+ j = isatty(i);
+ close(i);
+ return j;
+#else
+ struct stat x;
+
+ if(stat(s, &x) == -1) return(0);
+#ifdef S_IFMT
+ switch(x.st_mode&S_IFMT) {
+ case S_IFREG:
+ case S_IFDIR:
+ return(0);
+ }
+#else
+#ifdef S_ISREG
+ /* POSIX version */
+ if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode))
+ return(0);
+ else
+#else
+ Help! How does stat work on this system?
+#endif
+#endif
+ return(1);
+#endif
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "fp.h"
+
+extern int cursor;
+rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
+{ int ch;
+ for(;cursor>0;cursor--) if((ch=(*getn)())<0) return(ch);
+ if(cursor<0)
+ { if(recpos+cursor < 0) /*err(elist->cierr,110,"fmt")*/
+ cursor = -recpos; /* is this in the standard? */
+ if(external == 0) {
+ extern char *icptr;
+ icptr += cursor;
+ }
+ else if(curunit && curunit->useek)
+ (void) fseek(cf,(long) cursor,SEEK_CUR);
+ else
+ err(elist->cierr,106,"fmt");
+ recpos += cursor;
+ cursor=0;
+ }
+ switch(p->op)
+ {
+ default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
+ sig_die(fmtbuf, 1);
+ case I: ch = (rd_I((uint *)ptr,p->p1,len, 10));
+ break;
+ case IM: ch = (rd_I((uint *)ptr,p->p1,len, 10));
+ break;
+ case O: ch = (rd_I((uint *)ptr, p->p1, len, 8));
+ break;
+ case L: ch = (rd_L((ftnint *)ptr,p->p1));
+ break;
+ case A: ch = (rd_A(ptr,len));
+ break;
+ case AW:
+ ch = (rd_AW(ptr,p->p1,len));
+ break;
+ case E: case EE:
+ case D:
+ case G:
+ case GE:
+ case F: ch = (rd_F((ufloat *)ptr,p->p1,p->p2,len));
+ break;
+ }
+ if(ch == 0) return(ch);
+ else if(ch == EOF) return(EOF);
+ clearerr(cf);
+ return(errno);
+}
+rd_ned(p) struct syl *p;
+{
+ switch(p->op)
+ {
+ default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
+ sig_die(fmtbuf, 1);
+ case APOS:
+ return(rd_POS(*(char **)&p->p2));
+ case H: return(rd_H(p->p1,*(char **)&p->p2));
+ case SLASH: return((*donewrec)());
+ case TR:
+ case X: cursor += p->p1;
+ return(1);
+ case T: cursor=p->p1-recpos - 1;
+ return(1);
+ case TL: cursor -= p->p1;
+ if(cursor < -recpos) /* TL1000, 1X */
+ cursor = -recpos;
+ return(1);
+ }
+}
+rd_I(n,w,len, base) ftnlen len; uint *n; register int base;
+{ long x;
+ int sign,ch;
+ char s[84], *ps;
+ ps=s; x=0;
+ while (w)
+ {
+ GET(ch);
+ if (ch==',' || ch=='\n') break;
+ *ps=ch; ps++; w--;
+ }
+ *ps='\0';
+ ps=s;
+ while (*ps==' ') ps++;
+ if (*ps=='-') { sign=1; ps++; }
+ else { sign=0; if (*ps=='+') ps++; }
+loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
+ if (*ps==' ') {if (cblank) x *= base; ps++; goto loop;}
+ if(sign) x = -x;
+ if(len==sizeof(integer)) n->il=x;
+ else if(len == sizeof(char)) n->ic = x;
+ else n->is=x;
+ if (*ps) return(errno=115); else return(0);
+}
+rd_L(n,w) ftnint *n;
+{ int ch;
+ char s[84], *ps;
+ ps=s;
+ while (w) {
+ GET(ch);
+ if (ch==','||ch=='\n') break;
+ *ps=ch;
+ ps++; w--;
+ }
+ *ps='\0';
+ ps=s; while (*ps==' ') ps++;
+ if (*ps=='.') ps++;
+ if (*ps=='t' || *ps == 'T') { *n=1; return(0); }
+ else if (*ps == 'f' || *ps == 'F') { *n=0; return(0); }
+ else return(errno=116);
+}
+
+#include "ctype.h"
+
+rd_F(p, w, d, len)
+ftnlen len;
+ufloat *p;
+{
+ char s[FMAX+EXPMAXDIGS+4];
+ register int ch;
+ register char *sp, *spe, *sp1;
+ double atof(), x;
+ int scale1, se;
+ long e, exp;
+
+ sp1 = sp = s;
+ spe = sp + FMAX;
+ exp = -d;
+ x = 0.;
+
+ do {
+ GET(ch);
+ w--;
+ } while (ch == ' ' && w);
+ switch(ch) {
+ case '-': *sp++ = ch; sp1++; spe++;
+ case '+':
+ if (!w) goto zero;
+ --w;
+ GET(ch);
+ }
+ while(ch == ' ') {
+blankdrop:
+ if (!w--) goto zero; GET(ch); }
+ while(ch == '0')
+ { if (!w--) goto zero; GET(ch); }
+ if (ch == ' ' && cblank)
+ goto blankdrop;
+ scale1 = scale;
+ while(isdigit(ch)) {
+digloop1:
+ if (sp < spe) *sp++ = ch;
+ else ++exp;
+digloop1e:
+ if (!w--) goto done;
+ GET(ch);
+ }
+ if (ch == ' ') {
+ if (cblank)
+ { ch = '0'; goto digloop1; }
+ goto digloop1e;
+ }
+ if (ch == '.') {
+ exp += d;
+ if (!w--) goto done;
+ GET(ch);
+ if (sp == sp1) { /* no digits yet */
+ while(ch == '0') {
+skip01:
+ --exp;
+skip0:
+ if (!w--) goto done;
+ GET(ch);
+ }
+ if (ch == ' ') {
+ if (cblank) goto skip01;
+ goto skip0;
+ }
+ }
+ while(isdigit(ch)) {
+digloop2:
+ if (sp < spe)
+ { *sp++ = ch; --exp; }
+digloop2e:
+ if (!w--) goto done;
+ GET(ch);
+ }
+ if (ch == ' ') {
+ if (cblank)
+ { ch = '0'; goto digloop2; }
+ goto digloop2e;
+ }
+ }
+ switch(ch) {
+ default:
+ break;
+ case '-': se = 1; goto signonly;
+ case '+': se = 0; goto signonly;
+ case 'e':
+ case 'E':
+ case 'd':
+ case 'D':
+ if (!w--)
+ goto bad;
+ GET(ch);
+ while(ch == ' ') {
+ if (!w--)
+ goto bad;
+ GET(ch);
+ }
+ se = 0;
+ switch(ch) {
+ case '-': se = 1;
+ case '+':
+signonly:
+ if (!w--)
+ goto bad;
+ GET(ch);
+ }
+ while(ch == ' ') {
+ if (!w--)
+ goto bad;
+ GET(ch);
+ }
+ if (!isdigit(ch))
+ goto bad;
+
+ e = ch - '0';
+ for(;;) {
+ if (!w--)
+ { ch = '\n'; break; }
+ GET(ch);
+ if (!isdigit(ch)) {
+ if (ch == ' ') {
+ if (cblank)
+ ch = '0';
+ else continue;
+ }
+ else
+ break;
+ }
+ e = 10*e + ch - '0';
+ if (e > EXPMAX && sp > sp1)
+ goto bad;
+ }
+ if (se)
+ exp -= e;
+ else
+ exp += e;
+ scale1 = 0;
+ }
+ switch(ch) {
+ case '\n':
+ case ',':
+ break;
+ default:
+bad:
+ return (errno = 115);
+ }
+done:
+ if (sp > sp1) {
+ while(*--sp == '0')
+ ++exp;
+ if (exp -= scale1)
+ sprintf(sp+1, "e%ld", exp);
+ else
+ sp[1] = 0;
+ x = atof(s);
+ }
+zero:
+ if (len == sizeof(real))
+ p->pf = x;
+ else
+ p->pd = x;
+ return(0);
+ }
+
+
+rd_A(p,len) char *p; ftnlen len;
+{ int i,ch;
+ for(i=0;i<len;i++)
+ { GET(ch);
+ *p++=VAL(ch);
+ }
+ return(0);
+}
+rd_AW(p,w,len) char *p; ftnlen len;
+{ int i,ch;
+ if(w>=len)
+ { for(i=0;i<w-len;i++)
+ GET(ch);
+ for(i=0;i<len;i++)
+ { GET(ch);
+ *p++=VAL(ch);
+ }
+ return(0);
+ }
+ for(i=0;i<w;i++)
+ { GET(ch);
+ *p++=VAL(ch);
+ }
+ for(i=0;i<len-w;i++) *p++=' ';
+ return(0);
+}
+rd_H(n,s) char *s;
+{ int i,ch;
+ for(i=0;i<n;i++)
+ if((ch=(*getn)())<0) return(ch);
+ else *s++ = ch=='\n'?' ':ch;
+ return(1);
+}
+rd_POS(s) char *s;
+{ char quote;
+ int ch;
+ quote= *s++;
+ for(;*s;s++)
+ if(*s==quote && *(s+1)!=quote) break;
+ else if((ch=(*getn)())<0) return(ch);
+ else *s = ch=='\n'?' ':ch;
+ return(1);
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+integer f_rew(a) alist *a;
+{
+ unit *b;
+ if(a->aunit>=MXUNIT || a->aunit<0)
+ err(a->aerr,101,"rewind");
+ b = &units[a->aunit];
+ if(b->ufd == NULL || b->uwrt == 3)
+ return(0);
+ if(!b->useek)
+ err(a->aerr,106,"rewind")
+ if(b->uwrt) {
+ (void) t_runc(a);
+ b->uwrt = 3;
+ }
+ rewind(b->ufd);
+ b->uend=0;
+ return(0);
+}
--- /dev/null
+/* read sequential formatted external */
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+extern int x_getc(),rd_ed(),rd_ned();
+extern int x_endp(),x_rev(),xrd_SL();
+integer s_rsfe(a) cilist *a; /* start */
+{ int n;
+ if(!init) f_init();
+ if(n=c_sfe(a)) return(n);
+ reading=1;
+ sequential=1;
+ formatted=1;
+ external=1;
+ elist=a;
+ cursor=recpos=0;
+ scale=0;
+ fmtbuf=a->cifmt;
+ curunit= &units[a->ciunit];
+ cf=curunit->ufd;
+ if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
+ getn= x_getc;
+ doed= rd_ed;
+ doned= rd_ned;
+ fmt_bg();
+ doend=x_endp;
+ donewrec=xrd_SL;
+ dorevert=x_rev;
+ cblank=curunit->ublnk;
+ cplus=0;
+ if(curunit->uwrt && nowreading(curunit))
+ err(a->cierr,errno,"read start");
+ return(0);
+}
+xrd_SL()
+{ int ch;
+ if(!curunit->uend)
+ while((ch=getc(cf))!='\n' && ch!=EOF);
+ cursor=recpos=0;
+ return(1);
+}
+x_getc()
+{ int ch;
+ if(curunit->uend) return(EOF);
+ ch = getc(cf);
+ if(ch!=EOF && ch!='\n')
+ { recpos++;
+ return(ch);
+ }
+ if(ch=='\n')
+ { (void) ungetc(ch,cf);
+ return(ch);
+ }
+ if(curunit->uend || feof(cf))
+ { errno=0;
+ curunit->uend=1;
+ return(-1);
+ }
+ return(-1);
+}
+x_endp()
+{
+ (void) xrd_SL();
+ return(0);
+}
+x_rev()
+{
+ (void) xrd_SL();
+ return(0);
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+
+extern flag lquit;
+extern int lcount;
+extern int l_read();
+extern char *icptr;
+extern char *icend;
+extern icilist *svic;
+extern int icnum, recpos;
+extern int (*l_getc)(), (*l_ungetc)();
+
+int i_getc()
+{
+ if(++recpos >= svic->icirlen) {
+ if (recpos == svic->icirlen)
+ return '\n';
+ z_rnew();
+ }
+ if(icptr >= icend) err(svic->iciend,(EOF),"endfile");
+ return(*icptr++);
+ }
+
+int i_ungetc(ch)
+ int ch;
+{
+ if (--recpos == svic->icirlen)
+ return '\n';
+ if (recpos < -1)
+ err(svic->icierr,110,"recend");
+ /* *--icptr == ch, and icptr may point to read-only memory */
+ return *--icptr /* = ch */;
+ }
+
+ static void
+c_lir(a)
+ icilist *a;
+{
+ extern int l_eof;
+ reading = 1;
+ external = 0;
+ formatted = 1;
+ svic = a;
+ L_len = a->icirlen;
+ recpos = -1;
+ icnum = recpos = 0;
+ cursor = 0;
+ l_getc = i_getc;
+ l_ungetc = i_ungetc;
+ l_eof = 0;
+ icptr = a->iciunit;
+ icend = icptr + a->icirlen*a->icirnum;
+ cf = 0;
+ curunit = 0;
+ }
+
+
+integer s_rsli(a) icilist *a;
+{
+ lioproc = l_read;
+ lquit = 0;
+ lcount = 0;
+ c_lir(a);
+ return(0);
+ }
+
+integer e_rsli()
+{ return 0; }
+
+s_rsni(a)
+ icilist *a;
+{
+ cilist ca;
+ ca.ciend = a->iciend;
+ ca.cierr = a->icierr;
+ ca.cifmt = a->icifmt;
+ c_lir(a);
+ return x_rsne(&ca);
+ }
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+
+#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
+#define MAXDIM 20 /* maximum number of subscripts */
+
+ extern char *malloc(), *memset();
+
+ struct dimen {
+ ftnlen extent;
+ ftnlen curval;
+ ftnlen delta;
+ ftnlen stride;
+ };
+ typedef struct dimen dimen;
+
+ struct hashentry {
+ struct hashentry *next;
+ char *name;
+ Vardesc *vd;
+ };
+ typedef struct hashentry hashentry;
+
+ struct hashtab {
+ struct hashtab *next;
+ Namelist *nl;
+ int htsize;
+ hashentry *tab[1];
+ };
+ typedef struct hashtab hashtab;
+
+ static hashtab *nl_cache;
+ static n_nlcache;
+ static hashentry **zot;
+ extern ftnlen typesize[];
+
+ extern flag lquit;
+ extern int lcount;
+ extern int (*l_getc)(), (*l_ungetc)(), t_getc(), ungetc();
+
+ static Vardesc *
+hash(ht, s)
+ hashtab *ht;
+ register char *s;
+{
+ register int c, x;
+ register hashentry *h;
+ char *s0 = s;
+
+ for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
+ x += c;
+ for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
+ if (!strcmp(s0, h->name))
+ return h->vd;
+ return 0;
+ }
+
+ hashtab *
+mk_hashtab(nl)
+ Namelist *nl;
+{
+ int nht, nv;
+ hashtab *ht;
+ Vardesc *v, **vd, **vde;
+ hashentry *he;
+
+ hashtab **x, **x0, *y;
+ for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
+ if (nl == y->nl)
+ return y;
+ if (n_nlcache >= MAX_NL_CACHE) {
+ /* discard least recently used namelist hash table */
+ y = *x0;
+ free((char *)y->next);
+ y->next = 0;
+ }
+ else
+ n_nlcache++;
+ nv = nl->nvars;
+ if (nv >= 0x4000)
+ nht = 0x7fff;
+ else {
+ for(nht = 1; nht < nv; nht <<= 1);
+ nht += nht - 1;
+ }
+ ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
+ + nv*sizeof(hashentry));
+ if (!ht)
+ return 0;
+ he = (hashentry *)&ht->tab[nht];
+ ht->nl = nl;
+ ht->htsize = nht;
+ ht->next = nl_cache;
+ nl_cache = ht;
+ memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
+ vd = nl->vars;
+ vde = vd + nv;
+ while(vd < vde) {
+ v = *vd++;
+ if (!hash(ht, v->name)) {
+ he->next = *zot;
+ *zot = he;
+ he->name = v->name;
+ he->vd = v;
+ he++;
+ }
+ }
+ return ht;
+ }
+
+static char Alpha[256], Alphanum[256];
+
+ static void
+nl_init() {
+ register char *s;
+ register int c;
+
+ if(!init)
+ f_init();
+ for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
+ Alpha[c]
+ = Alphanum[c]
+ = Alpha[c + 'a' - 'A']
+ = Alphanum[c + 'a' - 'A']
+ = c;
+ for(s = "0123456789_"; c = *s++; )
+ Alphanum[c] = c;
+ }
+
+#define GETC(x) (x=(*l_getc)())
+#define Ungetc(x,y) (*l_ungetc)(x,y)
+
+ static int
+getname(s, slen)
+ register char *s;
+ int slen;
+{
+ register char *se = s + slen - 1;
+ register int ch;
+
+ GETC(ch);
+ if (!(*s++ = Alpha[ch & 0xff])) {
+ if (ch != EOF)
+ ch = 115;
+ err(elist->cierr, ch, "namelist read");
+ }
+ while(*s = Alphanum[GETC(ch) & 0xff])
+ if (s < se)
+ s++;
+ if (ch == EOF)
+ err(elist->cierr, ch == EOF ? -1 : 115, "namelist read");
+ if (ch > ' ')
+ Ungetc(ch,cf);
+ return *s = 0;
+ }
+
+ static int
+getnum(chp, val)
+ int *chp;
+ ftnlen *val;
+{
+ register int ch, sign;
+ register ftnlen x;
+
+ while(GETC(ch) <= ' ' && ch >= 0);
+ if (ch == '-') {
+ sign = 1;
+ GETC(ch);
+ }
+ else {
+ sign = 0;
+ if (ch == '+')
+ GETC(ch);
+ }
+ x = ch - '0';
+ if (x < 0 || x > 9)
+ return 115;
+ while(GETC(ch) >= '0' && ch <= '9')
+ x = 10*x + ch - '0';
+ while(ch <= ' ' && ch >= 0)
+ GETC(ch);
+ if (ch == EOF)
+ return EOF;
+ *val = sign ? -x : x;
+ *chp = ch;
+ return 0;
+ }
+
+ static int
+getdimen(chp, d, delta, extent, x1)
+ int *chp;
+ dimen *d;
+ ftnlen delta, extent, *x1;
+{
+ register int k;
+ ftnlen x2, x3;
+
+ if (k = getnum(chp, x1))
+ return k;
+ x3 = 1;
+ if (*chp == ':') {
+ if (k = getnum(chp, &x2))
+ return k;
+ x2 -= *x1;
+ if (*chp == ':') {
+ if (k = getnum(chp, &x3))
+ return k;
+ if (!x3)
+ return 123;
+ x2 /= x3;
+ }
+ if (x2 < 0 || x2 >= extent)
+ return 123;
+ d->extent = x2 + 1;
+ }
+ else
+ d->extent = 1;
+ d->curval = 0;
+ d->delta = delta;
+ d->stride = x3;
+ return 0;
+ }
+
+ static char where0[] = "namelist read start ";
+
+x_rsne(a)
+ cilist *a;
+{
+ int ch, got1, k, n, nd;
+ Namelist *nl;
+ static char where[] = "namelist read";
+ char buf[64];
+ hashtab *ht;
+ Vardesc *v;
+ dimen *dn, *dn0, *dn1;
+ ftnlen *dims, *dims1;
+ ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
+ ftnint type;
+ char *vaddr;
+ long iva, ivae;
+ dimen dimens[MAXDIM], substr;
+
+ if (!Alpha['a'])
+ nl_init();
+ reading=1;
+ formatted=1;
+ lquit = 0;
+ lcount = 0;
+ got1 = 0;
+ for(;;) switch(GETC(ch)) {
+ case EOF:
+ err(a->ciend,(EOF),where0);
+ case '&':
+ case '$':
+ goto have_amp;
+ default:
+ if (ch <= ' ' && ch >= 0)
+ continue;
+ err(a->cierr, 115, where0);
+ }
+ have_amp:
+ if (ch = getname(buf,sizeof(buf)))
+ return ch;
+ nl = (Namelist *)a->cifmt;
+ if (strcmp(buf, nl->name))
+ err(a->cierr, 118, where0);
+ ht = mk_hashtab(nl);
+ if (!ht)
+ err(elist->cierr, 113, where0);
+ for(;;) {
+ for(;;) switch(GETC(ch)) {
+ case EOF:
+ if (got1)
+ return 0;
+ err(a->ciend,(EOF),where0);
+ case '/':
+ case '$':
+ return 0;
+ default:
+ if (ch <= ' ' && ch >= 0 || ch == ',')
+ continue;
+ Ungetc(ch,cf);
+ if (ch = getname(buf,sizeof(buf)))
+ return ch;
+ goto havename;
+ }
+ havename:
+ v = hash(ht,buf);
+ if (!v)
+ err(a->cierr, 119, where);
+ while(GETC(ch) <= ' ' && ch >= 0);
+ vaddr = v->addr;
+ type = v->type;
+ if (type < 0) {
+ size = -type;
+ type = TYCHAR;
+ }
+ else
+ size = typesize[type];
+ ivae = size;
+ iva = 0;
+ if (ch == '(' /*)*/ ) {
+ dn = dimens;
+ if (!(dims = v->dims)) {
+ if (type != TYCHAR)
+ err(a->cierr, 122, where);
+ if (k = getdimen(&ch, dn, (ftnlen)size,
+ (ftnlen)size, &b))
+ err(a->cierr, k, where);
+ if (ch != ')')
+ err(a->cierr, 115, where);
+ b1 = dn->extent;
+ if (--b < 0 || b + b1 > size)
+ return 124;
+ iva += b;
+ size = b1;
+ while(GETC(ch) <= ' ' && ch >= 0);
+ goto scalar;
+ }
+ nd = dims[0];
+ nomax = span = dims[1];
+ ivae = iva + size*nomax;
+ if (k = getdimen(&ch, dn, size, nomax, &b))
+ err(a->cierr, k, where);
+ no = dn->extent;
+ b0 = dims[2];
+ dims1 = dims += 3;
+ ex = 1;
+ for(n = 1; n++ < nd; dims++) {
+ if (ch != ',')
+ err(a->cierr, 115, where);
+ dn1 = dn + 1;
+ span /= *dims;
+ if (k = getdimen(&ch, dn1, dn->delta**dims,
+ span, &b1))
+ err(a->cierr, k, where);
+ ex *= *dims;
+ b += b1*ex;
+ no *= dn1->extent;
+ dn = dn1;
+ }
+ if (ch != ')')
+ err(a->cierr, 115, where);
+ b -= b0;
+ if (b < 0 || b >= nomax)
+ err(a->cierr, 125, where);
+ iva += size * b;
+ dims = dims1;
+ while(GETC(ch) <= ' ' && ch >= 0);
+ no1 = 1;
+ dn0 = dimens;
+ if (type == TYCHAR && ch == '(' /*)*/) {
+ if (k = getdimen(&ch, &substr, size, size, &b))
+ err(a->cierr, k, where);
+ if (ch != ')')
+ err(a->cierr, 115, where);
+ b1 = substr.extent;
+ if (--b < 0 || b + b1 > size)
+ return 124;
+ iva += b;
+ b0 = size;
+ size = b1;
+ while(GETC(ch) <= ' ' && ch >= 0);
+ if (b1 < b0)
+ goto delta_adj;
+ }
+ for(; dn0 < dn; dn0++) {
+ if (dn0->extent != *dims++ || dn0->stride != 1)
+ break;
+ no1 *= dn0->extent;
+ }
+ if (dn0 == dimens && dimens[0].stride == 1) {
+ no1 = dimens[0].extent;
+ dn0++;
+ }
+ delta_adj:
+ ex = 0;
+ for(dn1 = dn0; dn1 <= dn; dn1++)
+ ex += (dn1->extent-1)
+ * (dn1->delta *= dn1->stride);
+ for(dn1 = dn; dn1 > dn0; dn1--) {
+ ex -= (dn1->extent - 1) * dn1->delta;
+ dn1->delta -= ex;
+ }
+ }
+ else if (dims = v->dims) {
+ no = no1 = dims[1];
+ ivae = iva + no*size;
+ }
+ else
+ scalar:
+ no = no1 = 1;
+ if (ch != '=')
+ err(a->cierr, 115, where);
+ got1 = 1;
+ readloop:
+ for(;;) {
+ if (iva >= ivae || iva < 0)
+ goto mustend;
+ else if (iva + no1*size > ivae) {
+ no1 = (ivae - iva)/size;
+ l_read(&no1, vaddr + iva, size, type);
+ mustend:
+ if (GETC(ch) == '/' || ch == '$')
+ lquit = 1;
+ else
+ err(a->cierr, 125, where);
+ }
+ else
+ l_read(&no1, vaddr + iva, size, type);
+ if (lquit)
+ return 0;
+ if ((no -= no1) <= 0)
+ break;
+ for(dn1 = dn0; dn1 <= dn; dn1++) {
+ if (++dn1->curval < dn1->extent) {
+ iva += dn1->delta;
+ goto readloop;
+ }
+ dn1->curval = 0;
+ }
+ break;
+ }
+ }
+ }
+
+ integer
+s_rsne(a)
+ cilist *a;
+{
+ int n;
+ extern integer e_rsle();
+ external=1;
+ if(n = c_le(a))
+ return n;
+ if(curunit->uwrt && nowreading(curunit))
+ err(a->cierr,errno,where0);
+ l_getc = t_getc;
+ l_ungetc = ungetc;
+ if (n = x_rsne(a))
+ return n;
+ return e_rsle();
+ }
--- /dev/null
+/* sequential formatted external common routines*/
+#include "f2c.h"
+#include "fio.h"
+
+extern char *fmtbuf;
+
+integer e_rsfe()
+{ int n;
+ n=en_fio();
+ if (cf == stdout)
+ fflush(stdout);
+ else if (cf == stderr)
+ fflush(stderr);
+ fmtbuf=NULL;
+ return(n);
+}
+c_sfe(a) cilist *a; /* check */
+{ unit *p;
+ if(a->ciunit >= MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"startio");
+ p = &units[a->ciunit];
+ if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
+ if(!p->ufmt) err(a->cierr,102,"sfe")
+ return(0);
+}
+integer e_wsfe()
+{ return(e_rsfe());
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+extern int reclen;
+long recloc;
+
+integer s_rsue(a) cilist *a;
+{
+ int n;
+ if(!init) f_init();
+ reading=1;
+ if(n=c_sue(a)) return(n);
+ recpos=0;
+ if(curunit->uwrt && nowreading(curunit))
+ err(a->cierr, errno, "read start");
+ if(fread((char *)&reclen,sizeof(int),1,cf)
+ != 1)
+ { if(feof(cf))
+ { curunit->uend = 1;
+ err(a->ciend, EOF, "start");
+ }
+ clearerr(cf);
+ err(a->cierr, errno, "start");
+ }
+ return(0);
+}
+integer s_wsue(a) cilist *a;
+{
+ int n;
+ if(!init) f_init();
+ if(n=c_sue(a)) return(n);
+ reading=0;
+ reclen=0;
+ if(curunit->uwrt != 1 && nowwriting(curunit))
+ err(a->cierr, errno, "write start");
+ recloc=ftell(cf);
+ (void) fseek(cf,(long)sizeof(int),SEEK_CUR);
+ return(0);
+}
+c_sue(a) cilist *a;
+{
+ if(a->ciunit >= MXUNIT || a->ciunit < 0)
+ err(a->cierr,101,"startio");
+ external=sequential=1;
+ formatted=0;
+ curunit = &units[a->ciunit];
+ elist=a;
+ if(curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
+ err(a->cierr,114,"sue");
+ cf=curunit->ufd;
+ if(curunit->ufmt) err(a->cierr,103,"sue")
+ if(!curunit->useek) err(a->cierr,103,"sue")
+ return(0);
+}
+integer e_wsue()
+{ long loc;
+ (void) fwrite((char *)&reclen,sizeof(int),1,cf);
+ loc=ftell(cf);
+ (void) fseek(cf,recloc,SEEK_SET);
+ (void) fwrite((char *)&reclen,sizeof(int),1,cf);
+ (void) fseek(cf,loc,SEEK_SET);
+ return(0);
+}
+integer e_rsue()
+{
+ (void) fseek(cf,(long)(reclen-recpos+sizeof(int)),SEEK_CUR);
+ return(0);
+}
--- /dev/null
+#include "f2c.h"
+
+ftnlen typesize[] = { 0, 0, sizeof(shortint), sizeof(integer),
+ sizeof(real), sizeof(doublereal),
+ sizeof(complex), sizeof(doublecomplex),
+ sizeof(logical), sizeof(char) };
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+int reclen;
+do_us(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+{
+ if(reading)
+ {
+ recpos += *number * len;
+ if(recpos>reclen)
+ {
+ err(elist->ciend,(-1), "eof/uio");
+ }
+ (void) fread(ptr,(int)len,(int)(*number),cf);
+ return(0);
+ }
+ else
+ {
+ reclen += *number * len;
+ (void) fwrite(ptr,(int)len,(int)(*number),cf);
+ return(0);
+ }
+}
+integer do_uio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+{
+ if(sequential)
+ return(do_us(number,ptr,len));
+ else return(do_ud(number,ptr,len));
+}
+do_ud(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+{
+ recpos += *number * len;
+ if(recpos > curunit->url && curunit->url!=1)
+ err(elist->cierr,110,"eof/uio");
+ if(reading)
+ {
+ if(fread(ptr,(int)len,(int)(*number),cf)
+ != *number)
+ err(elist->cierr,27,"eof/uio")
+ else return(0);
+ }
+ (void) fwrite(ptr,(int)len,(int)(*number),cf);
+ return(0);
+}
--- /dev/null
+#ifndef MSDOS
+#include "sys/types.h"
+#include "sys/stat.h"
+#endif
+#include "f2c.h"
+#include "fio.h"
+
+g_char(a,alen,b) char *a,*b; ftnlen alen;
+{
+ char *x = a + alen, *y = b + alen;
+
+ for(;; y--) {
+ if (x <= a) {
+ *b = 0;
+ return;
+ }
+ if (*--x != ' ')
+ break;
+ }
+ *y-- = 0;
+ do *y-- = *x;
+ while(x-- > a);
+ }
+
+b_char(a,b,blen) char *a,*b; ftnlen blen;
+{ int i;
+ for(i=0;i<blen && *a!=0;i++) *b++= *a++;
+ for(;i<blen;i++) *b++=' ';
+}
+#ifndef MSDOS
+long inode(a, dev) char *a; int *dev;
+{ struct stat x;
+ if(stat(a,&x)<0) return(-1);
+ *dev = x.st_dev;
+ return(x.st_ino);
+}
+#endif
+
+#define INTBOUND sizeof(int)-1
+mvgbt(n,len,a,b) char *a,*b;
+{ register int num=n*len;
+ if( ((int)a&INTBOUND)==0 && ((int)b&INTBOUND)==0 && (num&INTBOUND)==0 )
+ { register int *x=(int *)a,*y=(int *)b;
+ num /= sizeof(int);
+ if(x>y) for(;num>0;num--) *y++= *x++;
+ else for(num--;num>=0;num--) *(y+num)= *(x+num);
+ }
+ else
+ { register char *x=a,*y=b;
+ if(x>y) for(;num>0;num--) *y++= *x++;
+ else for(num--;num>=0;num--) *(y+num)= *(x+num);
+ }
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "fp.h"
+#ifndef VAX
+#include "ctype.h"
+#endif
+
+wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
+{
+ char buf[FMAX+EXPMAXDIGS+4], *s, *se;
+ int d1, delta, e1, i, sign, signspace;
+ double dd;
+#ifndef VAX
+ int e0 = e;
+#endif
+
+ if(e <= 0)
+ e = 2;
+ if(scale) {
+ if(scale >= d + 2 || scale <= -d)
+ goto nogood;
+ }
+ if(scale <= 0)
+ --d;
+ if (len == sizeof(real))
+ dd = p->pf;
+ else
+ dd = p->pd;
+ if (dd >= 0.) {
+ sign = 0;
+ signspace = cplus;
+#ifndef VAX
+ if (!dd)
+ dd = 0.; /* avoid -0 */
+#endif
+ }
+ else {
+ signspace = sign = 1;
+ dd = -dd;
+ }
+ delta = w - (2 /* for the . and the d adjustment above */
+ + 2 /* for the E+ */ + signspace + d + e);
+ if (delta < 0) {
+nogood:
+ while(--w >= 0)
+ PUT('*');
+ return(0);
+ }
+ if (scale < 0)
+ d += scale;
+ if (d > FMAX) {
+ d1 = d - FMAX;
+ d = FMAX;
+ }
+ else
+ d1 = 0;
+ sprintf(buf,"%#.*E", d, dd);
+#ifndef VAX
+ /* check for NaN, Infinity */
+ if (!isdigit(buf[0])) {
+ delta = w - strlen(buf) - signspace;
+ if (delta < 0)
+ goto nogood;
+ while(--delta >= 0)
+ PUT(' ');
+ if (signspace)
+ PUT(sign ? '-' : '+');
+ for(s = buf; *s; s++)
+ PUT(*s);
+ return 0;
+ }
+#endif
+ se = buf + d + 3;
+ if (scale != 1 && dd)
+ sprintf(se, "%+.2d", atoi(se) + 1 - scale);
+ s = ++se;
+ if (e < 2) {
+ if (*s != '0')
+ goto nogood;
+ }
+#ifndef VAX
+ /* accommodate 3 significant digits in exponent */
+ if (s[2]) {
+#ifdef Pedantic
+ if (!e0 && !s[3])
+ for(s -= 2, e1 = 2; s[0] = s[1]; s++);
+
+ /* Pedantic gives the behavior that Fortran 77 specifies, */
+ /* i.e., requires that E be specified for exponent fields */
+ /* of more than 3 digits. With Pedantic undefined, we get */
+ /* the behavior that Cray displays -- you get a bigger */
+ /* exponent field if it fits. */
+#else
+ if (!e0) {
+ for(s -= 2, e1 = 2; s[0] = s[1]; s++)
+#ifdef CRAY
+ delta--;
+ if ((delta += 4) < 0)
+ goto nogood
+#endif
+ ;
+ }
+#endif
+ else if (e0 >= 0)
+ goto shift;
+ else
+ e1 = e;
+ }
+ else
+ shift:
+#endif
+ for(s += 2, e1 = 2; *s; ++e1, ++s)
+ if (e1 >= e)
+ goto nogood;
+ while(--delta >= 0)
+ PUT(' ');
+ if (signspace)
+ PUT(sign ? '-' : '+');
+ s = buf;
+ i = scale;
+ if (scale <= 0) {
+ PUT('.');
+ for(; i < 0; ++i)
+ PUT('0');
+ PUT(*s);
+ s += 2;
+ }
+ else if (scale > 1) {
+ PUT(*s);
+ s += 2;
+ while(--i > 0)
+ PUT(*s++);
+ PUT('.');
+ }
+ if (d1) {
+ se -= 2;
+ while(s < se) PUT(*s++);
+ se += 2;
+ do PUT('0'); while(--d1 > 0);
+ }
+ while(s < se)
+ PUT(*s++);
+ if (e < 2)
+ PUT(s[1]);
+ else {
+ while(++e1 <= e)
+ PUT('0');
+ while(*s)
+ PUT(*s++);
+ }
+ return 0;
+ }
+
+wrt_F(p,w,d,len) ufloat *p; ftnlen len;
+{
+ int d1, sign, n;
+ double x;
+ char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
+
+ x= (len==sizeof(real)?p->pf:p->pd);
+ if (d < MAXFRACDIGS)
+ d1 = 0;
+ else {
+ d1 = d - MAXFRACDIGS;
+ d = MAXFRACDIGS;
+ }
+ if (x < 0.)
+ { x = -x; sign = 1; }
+ else {
+ sign = 0;
+#ifndef VAX
+ if (!x)
+ x = 0.;
+#endif
+ }
+
+ if (n = scale)
+ if (n > 0)
+ do x *= 10.; while(--n > 0);
+ else
+ do x *= 0.1; while(++n < 0);
+
+#ifdef USE_STRLEN
+ sprintf(b = buf, "%#.*f", d, x);
+ n = strlen(b) + d1;
+#else
+ n = sprintf(b = buf, "%#.*f", d, x) + d1;
+#endif
+
+ if (buf[0] == '0' && d)
+ { ++b; --n; }
+ if (sign) {
+ /* check for all zeros */
+ for(s = b;;) {
+ while(*s == '0') s++;
+ switch(*s) {
+ case '.':
+ s++; continue;
+ case 0:
+ sign = 0;
+ }
+ break;
+ }
+ }
+ if (sign || cplus)
+ ++n;
+ if (n > w) {
+ while(--w >= 0)
+ PUT('*');
+ return 0;
+ }
+ for(w -= n; --w >= 0; )
+ PUT(' ');
+ if (sign)
+ PUT('-');
+ else if (cplus)
+ PUT('+');
+ while(n = *b++)
+ PUT(n);
+ while(--d1 >= 0)
+ PUT('0');
+ return 0;
+ }
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+extern int cursor;
+extern char *icvt(), *ecvt();
+int hiwater;
+icilist *svic;
+char *icptr;
+mv_cur() /* shouldn't use fseek because it insists on calling fflush */
+ /* instead we know too much about stdio */
+{
+ if(external == 0) {
+ if(cursor < 0) {
+ if(hiwater < recpos)
+ hiwater = recpos;
+ recpos += cursor;
+ icptr += cursor;
+ cursor = 0;
+ if(recpos < 0)
+ err(elist->cierr, 110, "left off");
+ }
+ else if(cursor > 0) {
+ if(recpos + cursor >= svic->icirlen)
+ err(elist->cierr, 110, "recend");
+ if(hiwater <= recpos)
+ for(; cursor > 0; cursor--)
+ (*putn)(' ');
+ else if(hiwater <= recpos + cursor) {
+ cursor -= hiwater - recpos;
+ icptr += hiwater - recpos;
+ recpos = hiwater;
+ for(; cursor > 0; cursor--)
+ (*putn)(' ');
+ }
+ else {
+ icptr += cursor;
+ recpos += cursor;
+ }
+ cursor = 0;
+ }
+ return(0);
+ }
+ if(cursor > 0) {
+ if(hiwater <= recpos)
+ for(;cursor>0;cursor--) (*putn)(' ');
+ else if(hiwater <= recpos + cursor) {
+#ifndef NON_UNIX_STDIO
+ if(cf->_ptr + hiwater - recpos < buf_end(cf))
+ cf->_ptr += hiwater - recpos;
+ else
+#endif
+ (void) fseek(cf, (long) (hiwater - recpos), SEEK_CUR);
+ cursor -= hiwater - recpos;
+ recpos = hiwater;
+ for(; cursor > 0; cursor--)
+ (*putn)(' ');
+ }
+ else {
+#ifndef NON_UNIX_STDIO
+ if(cf->_ptr + cursor < buf_end(cf))
+ cf->_ptr += cursor;
+ else
+#endif
+ (void) fseek(cf, (long)cursor, SEEK_CUR);
+ recpos += cursor;
+ }
+ }
+ if(cursor<0)
+ {
+ if(cursor+recpos<0) err(elist->cierr,110,"left off");
+#ifndef NON_UNIX_STDIO
+ if(cf->_ptr + cursor >= cf->_base)
+ cf->_ptr += cursor;
+ else
+#endif
+ if(curunit && curunit->useek)
+ (void) fseek(cf,(long)cursor,SEEK_CUR);
+ else
+ err(elist->cierr,106,"fmt");
+ if(hiwater < recpos)
+ hiwater = recpos;
+ recpos += cursor;
+ cursor=0;
+ }
+ return(0);
+}
+w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
+{
+ if(cursor && mv_cur()) return(mv_cur());
+ switch(p->op)
+ {
+ default:
+ fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
+ sig_die(fmtbuf, 1);
+ case I: return(wrt_I((uint *)ptr,p->p1,len, 10));
+ case IM:
+ return(wrt_IM((uint *)ptr,p->p1,p->p2,len));
+ case O: return(wrt_I((uint *)ptr, p->p1, len, 8));
+ case L: return(wrt_L((uint *)ptr,p->p1, len));
+ case A: return(wrt_A(ptr,len));
+ case AW:
+ return(wrt_AW(ptr,p->p1,len));
+ case D:
+ case E:
+ case EE:
+ return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
+ case G:
+ case GE:
+ return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
+ case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
+ }
+}
+w_ned(p) struct syl *p;
+{
+ switch(p->op)
+ {
+ default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
+ sig_die(fmtbuf, 1);
+ case SLASH:
+ return((*donewrec)());
+ case T: cursor = p->p1-recpos - 1;
+ return(1);
+ case TL: cursor -= p->p1;
+ if(cursor < -recpos) /* TL1000, 1X */
+ cursor = -recpos;
+ return(1);
+ case TR:
+ case X:
+ cursor += p->p1;
+ return(1);
+ case APOS:
+ return(wrt_AP(*(char **)&p->p2));
+ case H:
+ return(wrt_H(p->p1,*(char **)&p->p2));
+ }
+}
+wrt_I(n,w,len, base) uint *n; ftnlen len; register int base;
+{ int ndigit,sign,spare,i;
+ long x;
+ char *ans;
+ if(len==sizeof(integer)) x=n->il;
+ else if(len == sizeof(char)) x = n->ic;
+ else x=n->is;
+ ans=icvt(x,&ndigit,&sign, base);
+ spare=w-ndigit;
+ if(sign || cplus) spare--;
+ if(spare<0)
+ for(i=0;i<w;i++) (*putn)('*');
+ else
+ { for(i=0;i<spare;i++) (*putn)(' ');
+ if(sign) (*putn)('-');
+ else if(cplus) (*putn)('+');
+ for(i=0;i<ndigit;i++) (*putn)(*ans++);
+ }
+ return(0);
+}
+wrt_IM(n,w,m,len) uint *n; ftnlen len;
+{ int ndigit,sign,spare,i,xsign;
+ long x;
+ char *ans;
+ if(sizeof(integer)==len) x=n->il;
+ else if(len == sizeof(char)) x = n->ic;
+ else x=n->is;
+ ans=icvt(x,&ndigit,&sign, 10);
+ if(sign || cplus) xsign=1;
+ else xsign=0;
+ if(ndigit+xsign>w || m+xsign>w)
+ { for(i=0;i<w;i++) (*putn)('*');
+ return(0);
+ }
+ if(x==0 && m==0)
+ { for(i=0;i<w;i++) (*putn)(' ');
+ return(0);
+ }
+ if(ndigit>=m)
+ spare=w-ndigit-xsign;
+ else
+ spare=w-m-xsign;
+ for(i=0;i<spare;i++) (*putn)(' ');
+ if(sign) (*putn)('-');
+ else if(cplus) (*putn)('+');
+ for(i=0;i<m-ndigit;i++) (*putn)('0');
+ for(i=0;i<ndigit;i++) (*putn)(*ans++);
+ return(0);
+}
+wrt_AP(s)
+ char *s;
+{ char quote;
+ if(cursor && mv_cur()) return(mv_cur());
+ quote = *s++;
+ for(;*s;s++)
+ { if(*s!=quote) (*putn)(*s);
+ else if(*++s==quote) (*putn)(*s);
+ else return(1);
+ }
+ return(1);
+}
+wrt_H(a,s)
+ char *s;
+{
+ if(cursor && mv_cur()) return(mv_cur());
+ while(a--) (*putn)(*s++);
+ return(1);
+}
+wrt_L(n,len, sz) uint *n; ftnlen sz;
+{ int i;
+ long x;
+ if(sizeof(integer)==sz) x=n->il;
+ else if(sz == sizeof(char)) x = n->ic;
+ else x=n->is;
+ for(i=0;i<len-1;i++)
+ (*putn)(' ');
+ if(x) (*putn)('T');
+ else (*putn)('F');
+ return(0);
+}
+wrt_A(p,len) char *p; ftnlen len;
+{
+ while(len-- > 0) (*putn)(*p++);
+ return(0);
+}
+wrt_AW(p,w,len) char * p; ftnlen len;
+{
+ while(w>len)
+ { w--;
+ (*putn)(' ');
+ }
+ while(w-- > 0)
+ (*putn)(*p++);
+ return(0);
+}
+
+wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
+{ double up = 1,x;
+ int i,oldscale=scale,n,j;
+ x= len==sizeof(real)?p->pf:p->pd;
+ if(x < 0 ) x = -x;
+ if(x<.1) return(wrt_E(p,w,d,e,len));
+ for(i=0;i<=d;i++,up*=10)
+ { if(x>=up) continue;
+ scale=0;
+ if(e==0) n=4;
+ else n=e+2;
+ i=wrt_F(p,w-n,d-i,len);
+ for(j=0;j<n;j++) (*putn)(' ');
+ scale=oldscale;
+ return(i);
+ }
+ return(wrt_E(p,w,d,e,len));
+}
--- /dev/null
+/*write sequential formatted external*/
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+extern int x_putc(),w_ed(),w_ned();
+extern int xw_end(),xw_rev(),x_wSL();
+extern int hiwater;
+integer s_wsfe(a) cilist *a; /*start*/
+{ int n;
+ if(!init) f_init();
+ if(n=c_sfe(a)) return(n);
+ reading=0;
+ sequential=1;
+ formatted=1;
+ external=1;
+ elist=a;
+ hiwater = cursor=recpos=0;
+ nonl = 0;
+ scale=0;
+ fmtbuf=a->cifmt;
+ curunit = &units[a->ciunit];
+ cf=curunit->ufd;
+ if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
+ putn= x_putc;
+ doed= w_ed;
+ doned= w_ned;
+ doend=xw_end;
+ dorevert=xw_rev;
+ donewrec=x_wSL;
+ fmt_bg();
+ cplus=0;
+ cblank=curunit->ublnk;
+ if(curunit->uwrt != 1 && nowwriting(curunit))
+ err(a->cierr,errno,"write start");
+ return(0);
+}
+x_putc(c)
+{
+ /* this uses \n as an indicator of record-end */
+ if(c == '\n' && recpos < hiwater) { /* fseek calls fflush, a loss */
+#ifndef NON_UNIX_STDIO
+ if(cf->_ptr + hiwater - recpos < buf_end(cf))
+ cf->_ptr += hiwater - recpos;
+ else
+#endif
+ (void) fseek(cf, (long)(hiwater - recpos), SEEK_CUR);
+ }
+ putc(c,cf);
+ recpos++;
+}
+pr_put(c)
+{ static flag new = 1;
+ recpos++;
+ if(c=='\n')
+ { new=1;
+ putc(c,cf);
+ }
+ else if(new==1)
+ { new=0;
+ if(c=='0') putc('\n',cf);
+ else if(c=='1') putc('\f',cf);
+ }
+ else putc(c,cf);
+}
+x_wSL()
+{
+ (*putn)('\n');
+ recpos=0;
+ cursor = 0;
+ hiwater = 0;
+ return(1);
+}
+xw_end()
+{
+ if(nonl == 0)
+ (*putn)('\n');
+ hiwater = recpos = cursor = 0;
+ return(0);
+}
+xw_rev()
+{
+ if(workdone) (*putn)('\n');
+ hiwater = recpos = cursor = 0;
+ return(workdone=0);
+}
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "lio.h"
+extern int l_write(), t_putc(), x_wSL();
+
+integer s_wsle(a) cilist *a;
+{
+ int n;
+ if(!init) f_init();
+ if(n=c_le(a)) return(n);
+ reading=0;
+ external=1;
+ formatted=1;
+ putn = t_putc;
+ lioproc = l_write;
+ L_len = LINE;
+ donewrec = x_wSL;
+ if(curunit->uwrt != 1 && nowwriting(curunit))
+ err(a->cierr, errno, "list output start");
+ return(0);
+ }
+
+integer e_wsle()
+{
+ t_putc('\n');
+ recpos=0;
+ if (cf == stdout)
+ fflush(stdout);
+ else if (cf == stderr)
+ fflush(stderr);
+ return(0);
+ }
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+
+ integer
+s_wsne(a)
+ cilist *a;
+{
+ int n;
+ extern int (*donewrec)(), t_putc(), x_wSL();
+ extern integer e_wsle();
+
+ if(!init)
+ f_init();
+ if(n=c_le(a))
+ return(n);
+ reading=0;
+ external=1;
+ formatted=1;
+ putn = t_putc;
+ L_len = LINE;
+ donewrec = x_wSL;
+ if(curunit->uwrt != 1 && nowwriting(curunit))
+ err(a->cierr, errno, "namelist output start");
+ x_wsne(a);
+ return e_wsle();
+ }
--- /dev/null
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+#include "fmt.h"
+
+x_wsne(a)
+ cilist *a;
+{
+ Namelist *nl;
+ char *s;
+ Vardesc *v, **vd, **vde;
+ ftnint *number, type;
+ ftnlen *dims;
+ ftnlen size;
+ static ftnint one = 1;
+ extern ftnlen typesize[];
+
+ nl = (Namelist *)a->cifmt;
+ PUT('&');
+ for(s = nl->name; *s; s++)
+ PUT(*s);
+ PUT(' ');
+ vd = nl->vars;
+ vde = vd + nl->nvars;
+ while(vd < vde) {
+ v = *vd++;
+ s = v->name;
+ if (recpos+strlen(s)+2 >= L_len)
+ (*donewrec)();
+ while(*s)
+ PUT(*s++);
+ PUT(' ');
+ PUT('=');
+ number = (dims = v->dims) ? dims + 1 : &one;
+ type = v->type;
+ if (type < 0) {
+ size = -type;
+ type = TYCHAR;
+ }
+ else
+ size = typesize[type];
+ l_write(number, v->addr, size, type);
+ if (vd < vde) {
+ if (recpos+2 >= L_len)
+ (*donewrec)();
+ PUT(',');
+ PUT(' ');
+ }
+ else if (recpos+1 >= L_len)
+ (*donewrec)();
+ }
+ PUT('/');
+ }
public / ack.git / commitdiff