libi77

把fortran语言编的程序转为c语言编的程序, 运行环境linux

-#endif
-
-integer f_clos(cllist *a)
-#endif
-{	unit *b;
-
-	if(a->cunit >= MXUNIT) return(0);
-	b= &f__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)
-				t_runc((alist *)a);
-			if(b->ufnm) {
-				fclose(b->ufd);
-				free(b->ufnm);
-				}
-			break;
-		case 'd':
-		case 'D':
-		Delete:
-			if(b->ufnm) {
-				fclose(b->ufd);
-				unlink(b->ufnm); /*SYSDEP*/
-				free(b->ufnm);
-				}
-		}
-	b->ufd=NULL;
- done:
-	b->uend=0;
-	b->ufnm=NULL;
-	return(0);
-	}
- void
-#ifdef KR_headers
-f_exit()
-#else
-f_exit(void)
-#endif
-{	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);
-		}
-	}
-}
- int
-#ifdef KR_headers
-flush_()
-#else
-flush_(void)
-#endif
-{	int i;
-	for(i=0;i<MXUNIT;i++)
-		if(f__units[i].ufd != NULL && f__units[i].uwrt)
-			fflush(f__units[i].ufd);
-return 0;
-}
//GO.SYSIN DD libI77/close.c
echo libI77/dfe.c 1>&2
sed >libI77/dfe.c <<'//GO.SYSIN DD libI77/dfe.c' 's/^-//'
-#include "f2c.h"
-#include "fio.h"
-#include "fmt.h"
-
-y_rsk(Void)
-{
-	if(f__curunit->uend || f__curunit->url <= f__recpos
-		|| f__curunit->url == 1) return 0;
-	do {
-		getc(f__cf);
-	} while(++f__recpos < f__curunit->url);
-	return 0;
-}
-y_getc(Void)
-{
-	int ch;
-	if(f__curunit->uend) return(-1);
-	if((ch=getc(f__cf))!=EOF)
-	{
-		f__recpos++;
-		if(f__curunit->url>=f__recpos ||
-			f__curunit->url==1)
-			return(ch);
-		else	return(' ');
-	}
-	if(feof(f__cf))
-	{
-		f__curunit->uend=1;
-		errno=0;
-		return(-1);
-	}
-	err(f__elist->cierr,errno,"readingd");
-#ifdef __cplusplus
-	return 0;
-#endif
-}
-#ifdef KR_headers
-y_putc(c)
-#else
-y_putc(int c)
-#endif
-{
-	f__recpos++;
-	if(f__recpos <= f__curunit->url || f__curunit->url==1)
-		putc(c,f__cf);
-	else
-		err(f__elist->cierr,110,"dout");
-	return(0);
-}
-y_rev(Void)
-{	/*what about work done?*/
-	if(f__curunit->url==1 || f__recpos==f__curunit->url)
-		return(0);
-	while(f__recpos<f__curunit->url)
-		(*f__putn)(' ');
-	f__recpos=0;
-	return(0);
-}
-y_err(Void)
-{
-	err(f__elist->cierr, 110, "dfe");
-#ifdef __cplusplus
-	return 0;
-#endif
-}
-
-y_newrec(Void)
-{
-	if(f__curunit->url == 1 || f__recpos == f__curunit->url) {
-		f__hiwater = f__recpos = f__cursor = 0;
-		return(1);
-	}
-	if(f__hiwater > f__recpos)
-		f__recpos = f__hiwater;
-	y_rev();
-	f__hiwater = f__cursor = 0;
-	return(1);
-}
-
-#ifdef KR_headers
-c_dfe(a) cilist *a;
-#else
-c_dfe(cilist *a)
-#endif
-{
-	f__sequential=0;
-	f__formatted=f__external=1;
-	f__elist=a;
-	f__cursor=f__scale=f__recpos=0;
-	if(a->ciunit>MXUNIT || a->ciunit<0)
-		err(a->cierr,101,"startchk");
-	f__curunit = &f__units[a->ciunit];
-	if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
-		err(a->cierr,104,"dfe");
-	f__cf=f__curunit->ufd;
-	if(!f__curunit->ufmt) err(a->cierr,102,"dfe")
-	if(!f__curunit->useek) err(a->cierr,104,"dfe")
-	f__fmtbuf=a->cifmt;
-	(void) fseek(f__cf,(long)f__curunit->url * (a->cirec-1),SEEK_SET);
-	f__curunit->uend = 0;
-	return(0);
-}
-#ifdef KR_headers
-integer s_rdfe(a) cilist *a;
-#else
-integer s_rdfe(cilist *a)
-#endif
-{
-	int n;
-	if(!f__init) f_init();
-	if(n=c_dfe(a))return(n);
-	f__reading=1;
-	if(f__curunit->uwrt && f__nowreading(f__curunit))
-		err(a->cierr,errno,"read start");
-	f__getn = y_getc;
-	f__doed = rd_ed;
-	f__doned = rd_ned;
-	f__dorevert = f__donewrec = y_err;
-	f__doend = y_rsk;
-	if(pars_f(f__fmtbuf)<0)
-		err(a->cierr,100,"read start");
-	fmt_bg();
-	return(0);
-}
-#ifdef KR_headers
-integer s_wdfe(a) cilist *a;
-#else
-integer s_wdfe(cilist *a)
-#endif
-{
-	int n;
-	if(!f__init) f_init();
-	if(n=c_dfe(a)) return(n);
-	f__reading=0;
-	if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
-		err(a->cierr,errno,"startwrt");
-	f__putn = y_putc;
-	f__doed = w_ed;
-	f__doned= w_ned;
-	f__dorevert = y_err;
-	f__donewrec = y_newrec;
-	f__doend = y_rev;
-	if(pars_f(f__fmtbuf)<0)
-		err(a->cierr,100,"startwrt");
-	fmt_bg();
-	return(0);
-}
-integer e_rdfe(Void)
-{
-	(void) en_fio();
-	return(0);
-}
-integer e_wdfe(Void)
-{
-	return en_fio();
-}
//GO.SYSIN DD libI77/dfe.c
echo libI77/dolio.c 1>&2
sed >libI77/dolio.c <<'//GO.SYSIN DD libI77/dolio.c' 's/^-//'
-#include "f2c.h"
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-#ifdef KR_headers
-extern int (*f__lioproc)();
-
-integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
-#else
-extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
-
-integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len)
-#endif
-{
-	return((*f__lioproc)(number,ptr,len,*type));
-}
-#ifdef __cplusplus
-	}
-#endif
//GO.SYSIN DD libI77/dolio.c
echo libI77/due.c 1>&2
sed >libI77/due.c <<'//GO.SYSIN DD libI77/due.c' 's/^-//'
-#include "f2c.h"
-#include "fio.h"
-
-#ifdef KR_headers
-c_due(a) cilist *a;
-#else
-c_due(cilist *a)
-#endif
-{
-	if(!f__init) f_init();
-	if(a->ciunit>=MXUNIT || a->ciunit<0)
-		err(a->cierr,101,"startio");
-	f__sequential=f__formatted=f__recpos=0;
-	f__external=1;
-	f__curunit = &f__units[a->ciunit];
-	f__elist=a;
-	if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
-	f__cf=f__curunit->ufd;
-	if(f__curunit->ufmt) err(a->cierr,102,"cdue")
-	if(!f__curunit->useek) err(a->cierr,104,"cdue")
-	if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue")
-	(void) fseek(f__cf,(long)(a->cirec-1)*f__curunit->url,SEEK_SET);
-	f__curunit->uend = 0;
-	return(0);
-}
-#ifdef KR_headers
-integer s_rdue(a) cilist *a;
-#else
-integer s_rdue(cilist *a)
-#endif
-{
-	int n;
-	if(n=c_due(a)) return(n);
-	f__reading=1;
-	if(f__curunit->uwrt && f__nowreading(f__curunit))
-		err(a->cierr,errno,"read start");
-	return(0);
-}
-#ifdef KR_headers
-integer s_wdue(a) cilist *a;
-#else
-integer s_wdue(cilist *a)
-#endif
-{
-	int n;
-	if(n=c_due(a)) return(n);
-	f__reading=0;
-	if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
-		err(a->cierr,errno,"write start");
-	return(0);
-}
-integer e_rdue(Void)
-{
-	if(f__curunit->url==1 || f__recpos==f__curunit->url)
-		return(0);
-	(void) fseek(f__cf,(long)(f__curunit->url-f__recpos),SEEK_CUR);
-	if(ftell(f__cf)%f__curunit->url)
-		err(f__elist->cierr,200,"syserr");
-	return(0);
-}
-integer e_wdue(Void)
-{
-#ifdef ALWAYS_FLUSH
-	if (fflush(f__cf))
-		err(f__elist->cierr,errno,"write end");
-#endif
-	return(e_rdue());
-}
//GO.SYSIN DD libI77/due.c
echo libI77/endfile.c 1>&2
sed >libI77/endfile.c <<'//GO.SYSIN DD libI77/endfile.c' 's/^-//'
-#include "f2c.h"
-#include "fio.h"
-#ifndef NON_UNIX_STDIO
-#include "sys/types.h"
-#endif
-#include "rawio.h"
-
-#ifdef KR_headers
-extern char *strcpy();
-#else
-#undef abs
-#undef min
-#undef max
-#include "stdlib.h"
-#include "string.h"
-#endif
-
-#ifdef NON_UNIX_STDIO
-#ifndef unlink
-#define unlink remove
-#endif
-#else
-#ifdef MSDOS
-#include "io.h"
-#endif
-#endif
-
-#ifdef NON_UNIX_STDIO
-extern char *f__r_mode[], *f__w_mode[];
-#endif
-
-#ifdef KR_headers
-integer f_end(a) alist *a;
-#else
-integer f_end(alist *a)
-#endif
-{
-	unit *b;
-	if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
-	b = &f__units[a->aunit];
-	if(b->ufd==NULL) {
-		char nbuf[10];
-		(void) sprintf(nbuf,"fort.%ld",a->aunit);
-#ifdef NON_UNIX_STDIO
-		{ FILE *tf;
-			if (tf = fopen(nbuf, f__w_mode[0]))
-				fclose(tf);
-			}
-#else
-		close(creat(nbuf, 0666));
-#endif
-		return(0);
-		}
-	b->uend=1;
-	return(b->useek ? t_runc(a) : 0);
-}
-
- static int
-#ifdef NON_UNIX_STDIO
-#ifdef KR_headers
-copy(from, len, to) char *from, *to; register long len;
-#else
-copy(FILE *from, register long len, FILE *to)
-#endif
-{
-	int k, len1;
-	char buf[BUFSIZ];
-
-	while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
-		if (!fwrite(buf, len1, 1, to))
-			return 1;
-		if ((len -= len1) <= 0)
-			break;
-		}
-	return 0;
-	}
-#else
-#ifdef KR_headers
-copy(from, len, to) char *from, *to; register long len;
-#else
-copy(char *from, register long len, char *to)
-#endif
-{
-	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;
-	}
-#endif
-
-#ifndef L_tmpnam
-#define L_tmpnam 16
-#endif
-
- int
-#ifdef KR_headers
-t_runc(a) alist *a;
-#else
-t_runc(alist *a)
-#endif
-{
-	char nm[L_tmpnam+12];	/* extra space in case L_tmpnam is tiny */
-	long loc, len;
-	unit *b;
-#ifdef NON_UNIX_STDIO
-	FILE *bf, *tf;
-#else
-	FILE *bf;
-#endif
-	int rc = 0;
-
-	b = &f__units[a->aunit];
-	if(b->url)
-		return(0);	/*don't truncate direct files*/
-	loc=ftell(bf = b->ufd);
-	fseek(bf,0L,SEEK_END);
-	len=ftell(bf);
-	if (loc >= len || b->useek == 0 || b->ufnm == NULL)
-		return(0);
-#ifdef NON_UNIX_STDIO
-	fclose(b->ufd);
-#else
-	rewind(b->ufd);	/* empty buffer */
-#endif
-	if (!loc) {
-#ifdef NON_UNIX_STDIO
-		if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt])))
-#else
-		if (close(creat(b->ufnm,0666)))
-#endif
-			rc = 1;
-		if (b->uwrt)
-			b->uwrt = 1;
-		goto done;
-		}
-#ifdef _POSIX_SOURCE
-	tmpnam(nm);
-#else
-	strcpy(nm,"tmp.FXXXXXX");
-	mktemp(nm);
-#endif
-#ifdef NON_UNIX_STDIO
-	if (!(bf = fopen(b->ufnm, f__r_mode[0]))) {
- bad:
-		rc = 1;
-		goto done;
-		}
-	if (!(tf = fopen(nm, f__w_mode[0])))
-		goto bad;
-	if (copy(bf, loc, tf)) {
- bad1:
-		rc = 1;
-		goto done1;
-		}
-	if (!(bf = freopen(b->ufnm, f__w_mode[0], bf)))
-		goto bad1;
-	if (!(tf = freopen(nm, f__r_mode[0], tf)))
-		goto bad1;
-	if (copy(tf, loc, bf))
-		goto bad1;
-	if (f__w_mode[0] != f__w_mode[b->ufmt]) {
-	 	if (!(bf = freopen(b->ufnm, f__w_mode[b->ufmt|2], bf)))
-			goto bad1;
-		fseek(bf, loc, SEEK_SET);
-		}
-done1:
-	fclose(tf);
-	unlink(nm);
-done:
-	f__cf = b->ufd = bf;
-#else
-	if (copy(b->ufnm, loc, nm)
-	 || copy(nm, loc, b->ufnm))
-		rc = 1;
-	unlink(nm);
-	fseek(b->ufd, loc, SEEK_SET);
-done:
-#endif
-	if (rc)
-		err(a->aerr,111,"endfile");
-	return 0;
-	}
//GO.SYSIN DD libI77/endfile.c
echo libI77/err.c 1>&2
sed >libI77/err.c <<'//GO.SYSIN DD libI77/err.c' 's/^-//'
-#ifndef NON_UNIX_STDIO
-#include "sys/types.h"
-#include "sys/stat.h"
-#endif
-#include "f2c.h"
-#include "fio.h"
-#include "fmt.h"	/* for struct syl */
-#include "rawio.h"	/* for fcntl.h, fdopen */
-#ifdef NON_UNIX_STDIO
-#ifdef KR_headers
-extern char *malloc();
-#else
-#undef abs
-#undef min