/* RATMAC to FORTRAN preprocessor. Original, in fortran, by S.R. Hall.
   Converted to the C language by D. du Boulay (Dec 1996). Copyright to
   "The Xtal System", Crystallography Centre, The University of
   Western Australia. All rights reserved.                                  */

#define VERSION  " RFPP --- Ratmac-Ftn77 PreProcessor  (3.2/Oct92)\n"

#include <stdio.h>      /* file I.O. function defs */
#include <stdlib.h>     /* definition of "exit" function */
#include <string.h>     /* strncpy */
#include <ctype.h>      /* character type function defs */
#include <math.h>       /* mathematical functions defs */


#define FALSE      0
#define TRUE       1
#define min(a,b) ( (a) < (b) ? (a) : (b) ) /* a minimum function */
#define _far                /* null definition */
#define MACRO_LIMIT 500	   /* limit is normally 500 */
#define STRING_LEN  100     /* length of "string" buffer */
#define BUFMAX 4000         /* max length of ratmac reading buffer */
#define MAXSTK  100         /* maximum length of FOR(i=...) stack */
#define LINE_NUMBER  27000  /* default choice for line number sequence */
#define MAX_FILE_NUM 5      /* max number of open source files */
#define MACTAB_MAX	(MACRO_LIMIT*40) /* size of macro table *40 */
#define MAXOUT		72  /* output buffer length */
#define MAXLPP		80	 /* Max lines per page */

enum  CodeType {Alphanum,Macro,Endline,Endfile,Other,Number,Digraph,Blank};
enum  FuncType {Null,Ndo,Nif,Nfor,Nwhile,Nrepeat,Nelse,Nleftb};

#define CONC   0     /*  concatenate signal     */
#define TAB   -1     /*  tab to column 7 signal */
#define NEW   -2     /*  Start in col1 signal   */
#define SAVE  -3     /*  Save <for-reint> code  */ 
#define DIGIT -4     /*  Process digit string   */
#define CONT  -5     /*  Continue line flag     */


int             argstk[100];
int		macadr[MACRO_LIMIT+1];	       /* pointers to macro adress */
int		macdef[MACRO_LIMIT+1];	       /* length of macro definitns*/
int		macind[ 64] = {0};	       /* alphabetic index to names*/
int		macnam[MACRO_LIMIT+1];	       /* length of macro names */
int		macnex[MACRO_LIMIT+1] = {0};   /* next macro for same index*/
int		itab = -1,		       /* last entry in mactab */
		macm = 0,		       /* maximum macro number */
		mtab = 1,
		narg = -1,		       /* number of args for macro*/
		nbuf = BUFMAX,                  /* pointer to ibuf */
		num_fchars = 1,                 /* chars to be output*/
		nmac = 0,		       /* current macro number*/
		ndat = 1000;

int		accf = 1,
		Extrude_Flag = FALSE, /* set when extruding file */
		flags = TRUE,         /* normally false */
		flagr = FALSE,        /* normally false */
		flagd = TRUE,         /* normally false */
		forstk[MAXSTK+1],
		nerr = 0,             /* number of source code errors */
		nlab = LINE_NUMBER,   /* used for fortran line numbering */
		nert = 0,
		nbrc = 0,
		nsqb = 0,             /* number of square brackets */
		nfil = 0,             /* current file number */
		nfor = -1,            /* FOR condit stack pointer */
		ifor = 1,             /* FOR reinit string pointer */
		ilin = 0,             /* current source file line number*/
		llin = 3,             /* list file line number */
		olin = 1,             /* number of output fortran lines */
		Double_Quotes = -1;   /* for counting double quotes */

char            ibuf[BUFMAX+1],       /* main buffer for file reading*/
		obuf[72],             /* fortran output buffer ?*/
		lbuf[120] = " R:     F:  ",
		prog[7] = "      ",     /* preprocessed file name */
		mactab[MACTAB_MAX+1], /* storage space for macro defs */
		macstr[BUFMAX+1],
		forstr[BUFMAX+1];


    FILE    *Rat_Source,        /* fortran file 1 */
	    *Rat_Backup,        /* fortran file ? */
	    *RFP_List,          /* fortran file 8 */
	    *Fort_Output,       /* fortran file 7 */
	    *Extrude_File,      /* fortran file 10 */
		*ndev,          /* fortran aux file device number */
	     *filstk[MAX_FILE_NUM];/* list of auxilliary file pointers */

/* subroutine prototypes */
static  void       macexp(char *str,int *l,int *m);
static  void       gettok(char *token, int *l, int *m);
static	void       outstr(int l,char  *str,int m,int n);
static  void       eatup(int l, int m);
static  void       putmac(char *str,int l,int m, int *n);
static	void  _far sysmac(int l, int m);
static  void       error(int l,char *str,int m);
/* extern double   pow(double x,double y); */


/* Begin Main program */
void main()
{
	int     i,j,k,n,m,l,
		ifun,
		flag = TAB,
		funstk[MAXSTK+1],
		labstk[MAXSTK+1],
		ilab,
		IncludeFile,
		nfun,
		nstr,
		ntok,
		type;

	char    c,
		string[STRING_LEN+1]= " \n",
		fname[24]; /* temporary storage of include filenames */

	Rat_Source  = fopen("RFPRAT","r");    /* file 1 */
	Fort_Output = fopen("RFPFTN","w");    /* file 7 */
	RFP_List    = fopen("RFPLST","w");    /* file 8 */
	filstk[0]   = Rat_Source;
	(void) fprintf(RFP_List,VERSION);
	(void) fprintf(stdout,VERSION);

	ibuf[BUFMAX] = '#';             /* preset last char in input buf*/
	putmac("ARITH:]A"   ,6,2,&i);	/* store system macro arith */
	putmac("MACRO:]M"   ,6,2,&i);
	putmac("XMACRO:]X"  ,7,2,&i);
	putmac("IFELSE:]I"  ,7,2,&i);
	putmac("INCR:]+"    ,5,2,&i);
	putmac("DECR:]-"    ,5,2,&i);
	putmac("CHR:]C"     ,4,2,&i);
	putmac("ORD:]O"     ,4,2,&i);
	putmac("LENSTR:]L"  ,7,2,&i);
	putmac("SUBSTR:]S"  ,7,2,&i);
	putmac("FLAGON:]Y"  ,7,2,&i);
	putmac("FLAGOFF:]N" ,8,2,&i);
	putmac("PMACRO:]P"  ,7,2,&i);
	putmac("DMACRO:]D"  ,7,2,&i);
	putmac("CHARDATA:]E",9,2,&i);
	putmac("REALDATA:]G",9,2,&i);
	putmac("DBLEDATA:]J",9,2,&i);
	putmac("INTDATA:]H" ,8,2,&i);
	putmac("DATASTUFF:]F",10,2,&i);
	putmac("STRING:]R"  ,7,2,&i);
	putmac("SELECT:]Q"  ,7,2,&i);
	putmac("IFSEL:]Z"   ,6,2,&i);
	putmac("ENDSEL:]W"  ,7,2,&i);
	putmac("EXTRUDE:]U" ,8,2,&i);
	putmac("ENDEXT:]V"  ,7,2,&i);
	putmac("INCLUDE:INCLUDE $1            ",8,22,&i);
	putmac("SYSTEMHEADER:IFELSE:($2,,$PC-------$1,)    ",13,30,&i);
	putmac("YES:1"	    ,4,1,&i);
	putmac("NO:0"	    ,3,1,&i);

/*
 *     PROCESS ALL INPUT RATMAC SOURCE FILES
 */
        for(nfil=0; nfil>-1;nfil--) {/*loop over input source files*/
		ndev = filstk[nfil];
		nfun=-1;

	  for(;;) {    /* loop over all strings until EOF */
	        IncludeFile=FALSE;
		nstr=0;   /* point to first element of string */
		for (;;) {  /* loop until "include" is found */
			macexp(&string[nstr],&type,&ntok);
			nstr += ntok + 1;
			if (type == Endfile ) break;
			if (IncludeFile == FALSE) {
				if (strncmp(string,"INCLUDE",7) != 0) break ;
				IncludeFile = TRUE;
				}
			if (type == Blank) nstr -= ntok;
			if (type != Endline) continue;
			++nfil;
			if (nfil > MAX_FILE_NUM) error(1," ",0); /* too many files*/
			(void) strncpy(fname,&string[8],nstr-10); //modified to strip quotes
			fname[(nstr-10)]='\0';    /* append new line */
			if ( (ndev = fopen(fname,"r"))==(FILE *)NULL) {/* open include file */
				(void) fprintf(stdout,"unable to open file: %8s",fname);
				exit(-10);
				}
			filstk[nfil] = ndev;     /* store pointer in list*/
			break;
			} /* end of loop  until "include" found */

		if (type ==Endline || type == Blank) continue;
		if (type ==Endfile || IncludeFile == TRUE)  break;

		--nstr;          /* set length of string */
		c = string[0];   /* first character in string */
		if (c == '{' || (type == Digraph && c == '(' ) ) {
			++nbrc;
			ifun = Nleftb;  /* store function type */
			ilab = 0;
			}
		else if ( c == '}' || (type == Digraph && c == ')')) {
			--nbrc;
			ifun = Null;
			if (funstk[nfun] == Nleftb ) --nfun;
			else error(04," ",0);
			}
		else if (type == Digraph && c == 'P') {
			flag = NEW;
			ifun = Null;
			}
		else if (nstr == 2-1 && strncmp(string,"IF",2)==0 ) {
			if (ifun == Nelse)  ilab = CONC ;
			else                ilab = TAB;
			outstr(ilab,"IF",2-1,0);
			eatup(Nif,CONC);
			outstr(CONC,"THEN",4-1,0);
			ifun = Nif;
			}
		else if (nstr == 4-1 && strncmp(string,"ELSE",4)==0) {
			n=funstk[nfun];
			if (n != Nif) error(17," ",0);
			outstr(TAB,"ELSE ",5-1,0);
			ifun = Nelse ;
			ilab = CONC ;
			}
		else if (nstr == 6-1 && strncmp(string,"ELSEIF",6)==0) {
			n=funstk[nfun];
			if (n != Nif) error(17," ",0);
			++nfun;
			if (nfun > MAXSTK) error(05," ",0);
			funstk[nfun] = Nelse;
			labstk[nfun] = nlab ;
			outstr(TAB,"ELSE IF",7-1,0);
			eatup(Nif,CONC);
			outstr(CONC,"THEN",4-1,0);
			ifun=Nif;
			ilab=CONC;
			}
		else if (nstr == 2-1 && strncmp(string,"DO",2)==0) {
			outstr(TAB,"DO",2-1,nlab);
			eatup(Ndo,CONC);
			ifun=Ndo;
			ilab=2;
			}
		else if (nstr == 5-1 && strncmp(string,"WHILE",5)==0) {
			outstr(nlab,"IF",2-1,0);
			eatup(Nwhile,CONC);
			outstr(CONC,"THEN",4-1,0);
			ifun = Nwhile;
			ilab = 2;
			}
		else if (nstr == 6-1 && strncmp(string,"REPEAT",6)==0) {
			outstr(nlab,"CONTINUE",8-1,0);
			ifun = Nrepeat;
			ilab = 2;
			}
		else if (nstr == 3-1 && strncmp(string,"FOR",3)==0) {
			eatup (Nfor,TAB);  /* output for initialization */
			++nbuf;            /* get next char */
			if (ibuf[nbuf] != ';') { /* void "for condition" */
				--nbuf;
				outstr(nlab,"IF(",3-1,0); /* output "nlab if" */
				eatup(Nfor,CONC);       /* output for condition */
				outstr(CONC,")THEN",5-1,0); /* output "then */
				ifun = Nfor;             /* set function flag */
				}
			else {                          /* no for condition */
				outstr(nlab,"CONTINUE",8-1,0);
				ifun = -Nfor;
				}
			eatup(Nfor,SAVE);        /* save <for-reinit> in forstr */
			ilab= 2;                 /* store function type */
			++nlab;
			}
		else if ( (nstr == 4-1 && strncmp(string,"NEXT",4)==0) ||   /* next */
			  (nstr == 5-1 && strncmp(string,"BREAK",5)==0) ) { /* break */
			for(i=nfun; i >= 0; i--) {    /* loop for nested loops */
				n=abs(funstk[i]);     /* get function */
				l=abs(labstk[i]);     /* get label */
				if (n != Nwhile && n != Ndo && n != Nfor && n != Nrepeat) continue;
				if (nstr == 4-1) {   /* a next */
					outstr(TAB,"GOTO",4-1,l);
					if (n == Nfor)
					   forstk[nfor]=-abs(forstk[nfor]);
					}
				else {   /* this is a break */
					outstr(TAB,"GOTO",4-1,l+1); /* break */
					labstk[i]=-l;
				      }
				ifun = Null;
				break;              /* exit function loop */
				}
			if (i < 0) error(03," ",0);
			}
		else if (c == ';')         ifun = Null;
		else if (type == Number) {         /* all digit */
			outstr(DIGIT, string,nstr,0);
			eatup(Null,CONC);
			ifun = Null;
			}
		else {                     /* process all other strings */
			outstr(flag,string,nstr,0); /*output digit string */
			eatup(Null,CONC);    /* output to end of line */
			flag = TAB;
			ifun = Null;
			}


		if (ifun != Null) {     /* when functions are stacked */
			++nfun;         /* increment function type */
			if (nfun >MAXSTK) error(05," ",0); /* stack overflow */
			funstk[nfun]=ifun;     /* store function */
			if (ilab < 0) labstk[nfun] = 0 ;
			else  {
				labstk[nfun] = nlab;
				nlab += ilab;
				}
			continue;     /* get next string */
			}
  /*
#   IF <STATEMENT> CLOSED UNSTACK FUNCTIONS                             RFPP 222
#   ---------------------------------------                             RFPP 223
#
   */

		for( ;nfun>=0;nfun--) {
			n = funstk[nfun]; /* get function */
			m = labstk[nfun];
			l = abs(m);
			
			if (n == Nleftb) break; /* break on left bracket */
			if (n == Nif) {
				for(type=Endline; (type==Endline||type==Blank|| *string == ';') ; )
					macexp(string,&type,&ntok);
				if (type != Digraph) nbuf -= (ntok+1);
				else	             nbuf -= (2+0);  /********/
				if (strncmp(string,"ELSE",4)==0) break;
				if (l == 0) outstr(TAB,"END IF",6-1,0);
				}
			else if (n == Nelse) {
				if (nfun > 0) --nfun;
				if (labstk[nfun]==0)
					outstr(TAB,"END IF",6-1,0);
				}
			else if (n == Ndo) {  /*Test if <do> in stack*/
				outstr(l,"CONTINUE",8-1,0);
				if (m < 0) outstr(l+1,"CONTINUE",8-1,0);
				}
			else if (n == Nwhile || n == Nrepeat) {
				outstr(TAB,"GOTO",4-1,l);
				if (m < 0)      outstr(l+1,"CONTINUE",8-1,0);
				if (n== Nwhile) outstr(TAB,"END IF",6-1,0);
				}
			else if (abs(n) == Nfor) {     /*Test if <for> in stack*/
				i= forstk[nfor];
				j=abs(i);
				--nfor;
				k=ifor-j;
				ifor = j;
				if (i < 0) outstr(l,"CONTINUE",8-1,0);
				if (k > 0) outstr(TAB,&forstr[j],k-1,0);
					   outstr(TAB,"GOTO",4-1,l-1);
				if (m < 0) outstr(l+1,"CONTINUE",8-1,0);
				if (n > 0) outstr(TAB,"END IF",6-1,0);
				}

			}
		}
		fclose(ndev);
	}
	if (nert != 0) {
		(void) fprintf(RFP_List," Total Errors: %5d\n",nert);
		(void) fprintf(stdout," Total Errors: %5d\n",nert);
		}
        
	outstr(0," ",0,-1);  /* flush the buffer */
	fclose(Fort_Output);
	fclose(RFP_List);
	if (nert != 0) exit(1);
	exit(0);                    /* normal error free termination */
}

/* Subroutine MACEXP */
void macexp(char *token,int *type,int *ntok)
{
	char    temp[133] =  " ";
	char    c;
	int	i,ii,j,k,l,m,n,kjk;
	int     imac = -1,
		mmac = -1,
		macstk[MAXSTK+1],
		parlev[MAXSTK+1] = {0},
		Single_Quotes,
		npnt = 0;

	for( ; ; ){
		gettok(token,type,ntok);
		if (*type == Endfile) {
			if (mmac != -1) error(12," ",0);
			else return;       
			}
		c = token[0];                      /* first character of token */
		if (nsqb > 0) {       /* Do this bit when we are between square brack*/
			if      (c == '[') nsqb++;  /* increment square brack cnt */
			else if (c == ']') nsqb--;  /* decrement square brack cnt */
			if (nsqb == 0) continue; /* no more square brackets */
			if (mmac == -1) {
				if (*type == Endfile) error(12," ",0);
				else return;
				}
			if (*ntok >= 0) {
				kjk = *ntok + 1;
				if (imac + kjk >= BUFMAX) error(18,token,*ntok);
				(void) strncpy(&macstr[imac+1],token,kjk);
				imac += kjk;
				}
			}
		else if (*type == Macro) {		/* a macro name */
			putmac(token,*ntok+1,-1,&npnt);	/* check mactab */
			if (npnt == 0) {        /* macro name not in table */
				if (mmac == -1) { /* error storing macro */
					error(11,token,*ntok);
					break;
					}
				else {       
				       if (*ntok > 0) {      /* non null name length */
						kjk= *ntok +1;
						if (imac + kjk >= BUFMAX) 
							error(18,token,*ntok);
						(void) strncpy(&macstr[imac+1],token,kjk);
						imac += kjk;
						}
					}
			       }
			else {                /* macro name is in the table */
				if (++mmac > MAXSTK || ++narg > 100) error(05," ",0);
				macstk[mmac] = narg;	       /*	*/
				argstk[narg] = imac;           /* pointer to nth arg in macstr*/
				parlev[mmac] = 0;
				n = macnam[npnt];              /* macro name length*/
				l = macdef[npnt];	      /* macro def length */
				i = macadr[npnt]+n;	      /* def loc in mactab */
				if (l > 0) {                   /*copy tab def to temp */
					if (imac+l >= BUFMAX) error(18," ",0);
					(void) strncpy(&macstr[imac+1],&mactab[i],l);
					imac += l;
					}
				else macstr[imac+1]=' ';
				if (ibuf[nbuf+1] != '(' ) {    /* macro with no args */
					nbuf = nbuf -2;
					(void) strncpy(&ibuf[nbuf+1],"()",2);
					}
				if (flagd == TRUE) {
					if (mmac == 1) 
					(void) fprintf(RFP_List," >>>>>>>>>>> \n");
					(void) fprintf(RFP_List," >>>>>>>>>>> %3d%17.*s %*.*s\n",
						mmac,min(17,*ntok+1),token,l,l,&mactab[i]);
					}
				}
			}
		else if (c == '[') {             /* character is a square bracket*/
			nsqb=1;                  /* increase square bracket count*/
			continue;
			}
		else if (mmac == -1) {          /* break loop on type 3 */
			if (*ntok == 1 && c == '$') {	 /* convert digraph*/
				token[0] = token[1];
				*type = Digraph;
				*ntok = 0;
				}
			else if (c == '^') token[0] = ':';
			break;
			}
		else if (*type != Other) {
			if (*ntok >= 0 ) {
				kjk =  *ntok +1;
				if (imac + kjk > BUFMAX) error(18,token,*ntok);
				(void) strncpy(&macstr[imac+1],token,kjk);
				imac += kjk;
				}
			}

		else if (c == '(') {
			if (parlev[mmac] > 0) {
				if (*ntok >= 0) {    /* copy token to temp macro string */
				       kjk = *ntok +1;
				       if (imac + kjk >= BUFMAX) error(18,token,*ntok);
				       (void) strncpy(&macstr[imac+1],token,kjk);
				       imac += kjk;
				       }
			       }
			else {                      /* first parenth level ? */
				++narg;             /* increment number of brak args */
				argstk[narg]=imac;  /* point to location of parenth */
				}
			++parlev[mmac];             /* increment parenthesis level */
			}

		else if (c == ')') {               /* closing parenthesis */
			--parlev[mmac];            /* decrement level count */
			if (parlev[mmac] > 0) {    /* not terminating bracket of macro */
				if (*ntok >= 0) {
					kjk =  *ntok + 1;
					if (imac + kjk >= BUFMAX) error(18,token,*ntok);
					(void)strncpy(&macstr[imac+1],token,kjk);
					imac += kjk;
					}
				}
			else {                    /* terminating bracket of macro */
				++narg;
				argstk[narg]=imac;  /*end of prev*/
				i = macstk[mmac];
				j = argstk[i]+1;    /*begin of next */
				if (flagd == TRUE) {     /* debugging ? */
					(void)sprintf(temp," >>>>>>>>>>>> %4.4d                  ",mmac);
					ii = 35;
					for (k=i+1; k < narg; ++k) {	/*loop over arguments*/
						n=argstk[k];
						l=ii+argstk[k+1]-n;
						l=min(l,130);
						temp[ii]='<';
						if (l > ii) (void) strncpy(&temp[ii+1],&macstr[n+1],l-ii);
						(void)strcpy(&temp[l+1],">");
						ii= l+2;
						}
					(void) fprintf(RFP_List,"%*.*s\n",ii,ii,temp);
					if (mmac == 1 )(void) fprintf(RFP_List," >>>>>>>>>>>> \n");
					fflush(RFP_List);
					}
				if (macstr[j] == ']') sysmac(i,(j+1));	/* flag for system macro */
				else {
					Single_Quotes = -1;
					for (n = argstk[i+1] ;n >= j;n--) {
						if ((c=macstr[n]) == '\'') Single_Quotes=-Single_Quotes;
						    
				/* expand $x digraph macro arg number	*/
						if (n>j&& macstr[n-1]=='$'&& Single_Quotes!=1&& c>='1'&& c<='9'){
							--n;
							(void) sscanf(&c,"%1d",&m);
							m += i;
							if (m >=narg) continue;
							k=argstk[m];	     /* end of prev */
							l=argstk[m+1]-k;     /* length of curr*/
							if (l > 0) {
								nbuf -= l;
								if (nbuf < 0) error(18,&macstr[k+1],l);
								(void) strncpy(&ibuf[nbuf+1],&macstr[k+1],l);
								}
							}
						else {	/* copy all other characters to ibuf */
							if (--nbuf < 0) error(18,&c,1);
							(void) strncpy(&ibuf[nbuf+1],&c,1);
							}
						} /* end of for */
					}
				narg = i-1;
				imac = j-1;	 /* end of prev */
				--mmac;
				}
			}
		else if (c == ',' && parlev[mmac] == 1) {
			++narg;
			argstk[narg]=imac;
			}
		else {
			if (*ntok >= 0) {
				kjk = *ntok  +1;
				if (imac + kjk >=BUFMAX) error(18,token,*ntok);
				(void) strncpy(&macstr[imac+1],token, kjk);
				imac += kjk;
				}
			}
		}
	if (mmac != -1 && *type == Endfile) error(12," ",0);
}



/* subroutine gettok */
void gettok(char *token, int *type, int *ntok)
{
   static  int  ninp; /* number of chars on input buffer */
	int     aflag = 0;
	int     i;
	int     Single_Quotes;
	char    d,c,*k;
	*type = Number;                  /* default type */

	for(*ntok=0; *ntok<STRING_LEN; ++*ntok){
		++nbuf;
		if (nbuf <= BUFMAX && accf != 0) ; /* do nothing now */
		else for ( ; ; ) {               /* read the lines in ndev */
			if (fgets(ibuf,82,ndev) == (char *) NULL) {	/* read 80 chars */
				ninp = -1;      /* flag EOF */
				break;          /* break file reading loop */
				}

			ninp = strlen(ibuf);    /* get length of input line*/
			if (nfil == 0) ++ilin;  /* increment src line count */

			if (flags == TRUE) {    /* flag for listing input lines */
				++llin;         /* increment list line count */
			      /*	if (llin > 80) {  */ /* print header */
			      /*		fprintf(RFP_List,VERSION);
					llin=3;
					}      */
				if (num_fchars > 1)         
				    (void) fprintf(RFP_List," R: %4d F: %4d %*.*s\n",
				        ilin,olin+1,ninp-1,ninp-1,ibuf); /* list input string */
				else
				(void) fprintf(RFP_List," R: %4d F: %4d %*.*s\n",
					ilin,olin,ninp-1,ninp-1,ibuf); /* list input string */
				}

			if (Extrude_Flag == TRUE) {             /* if in Extrude mode */
				if (strncmp(ibuf,"ENDEXT:",7) &&
				    strncmp(ibuf,"endext:",7) &&
				    strncmp(&ibuf[3],"ENDEXT:",7) ){
					(void) fputs(ibuf,Extrude_File);	/* extrude line */
					continue;	     /* get next line */
					}
				}

			if (flagr == TRUE) {
				if (strncmp(&ibuf[8],":(R)",4)==0) flagr = FALSE;
				else {
					++olin;               /* increment no of olin */
					(void) fputs(ibuf,Fort_Output); /* output fortran */
fflush(Fort_Output);
					continue;             /* get next input line */
					}
				}

			if (ibuf[0] == '#') continue;    /* comment - get next line */

			/* else  the line must be processed */
			Single_Quotes = -1;
			d = ' ';                /* initialise */
			for(i=0;i<ninp;i++){    /* cycle over line chars */
				c = ibuf[i];
				if (c =='\'' && (d != '$' || Single_Quotes == 1))
					Single_Quotes = -Single_Quotes;
				else if (Single_Quotes == 1) continue;
				else if (c == '#')           break;/* begin comments */
				if (c =='\"') Double_Quotes = -Double_Quotes;
				else if (Double_Quotes == 1) continue;
				d = c;         /* copy second to first */
				if (islower(c)) ibuf[i] = (char) toupper(c); /* upper case */
				}

			nbuf = BUFMAX-i;         /* space for non comment chars*/
			k =  strncpy((ibuf+nbuf),ibuf,i); /*copy to end*/
			if (accf == 1)   break;           /* god knows ?? */
			if (nbuf > BUFMAX-6) continue;        /* empty line <6chars*/
			if (strncmp(&ibuf[nbuf],"IFSEL:" ,6) == 0) break;
			if (strncmp(&ibuf[nbuf],"ENDSEL:",7) == 0) break;
			} /* end of read ndev */

		if (ninp <= 0) break;          /* EOF for file ndev */
		c = ibuf[nbuf];                /* first char in buffer */
		accf = 1;                      /* God knows ?? */
		token[*ntok] = c;	       /* copy first char to token*/
		if (nbuf == BUFMAX-1) {        /* end of input buffer */
			if (c == '$') {        /* RATMAC line continuation*/
				--*ntok;       /* decrement char count */
				nbuf = BUFMAX; /* reset buffer count */
				continue;      /* get next ntok */
				}
			if (c == ',' && *ntok == 0) nbuf = BUFMAX; /* ??? */
			}
		if (c == '\'') {               /* another single quote */
			if (aflag == 0 && *ntok > 0) break;
			if (aflag == 0)  aflag = 1;
			else            aflag = 0;
			}
		if (aflag == 1 && nbuf < BUFMAX)  continue;  /* get next ntok */
		if (c >= 'A' && c <='Z') {     /* upper case alphabet */
			if (*type == Alphanum) continue; /* char mode - get next char */
			if (*ntok > 0) break;  /* not char mode so changing*/
			*type = Alphanum;             /* else set mode to char */
			continue;             /* get next ntok */
			}
		else if (c >= '0' && c <= '9') continue; /* numeric - get next */
		break;                        /* unknown character - break */
		} /* end of loop for ntok */


	if (*ntok == 100 ) error(10," ",0);   /* token exceeds max size */
	if (aflag == 1)  error(15," ",0);     /* incomplete quote string */
	if (ninp < 0) *type = Endfile;              /* EOF mode */
	else if (*ntok == 0) {                /* only one char */
		*type = Other;                    /* assume  ??? */
		if (c == '#' || c=='\n') *type = Endline; /* comment is type 3  */
		else if (c == ',') ;         /* type is 5 ?? */
		else if (c == '$') {         /*              */
			token[1] = ibuf[nbuf+1];  /* 2 char digraph */
			++nbuf;              /* increment buffer pointer */
			*ntok = 1;            /* token is now 2 chars */
			}
		else if (c == ' ') {         /* copy white space chars */
			for ( ++nbuf ; nbuf<BUFMAX; ++nbuf){
				if (ibuf[nbuf] != ' ') break;
				++*ntok;      /* increment token white space*/
				token[*ntok] = ' ';
				}
			--nbuf;               /* decrement nbuf */
			*type = Blank;            /* token is white space 8 */
			}
		else if (nsqb > 0) ;         /* Square brackets not closed */
		else if (ibuf [nbuf+1] == '=') {  /* part 2 of 2 char BOOL */
			++nbuf;              /* reading two chars */
			if (c == '=')       /* symbol is == */
				(void) strncpy(token,".EQ.",(*ntok=3)+1);
			else if (c == '!')  /* symbol is != */
				(void) strncpy(token,".NE.",(*ntok=3)+1);
			else if (c == '<')  /* symbol is <= */
				(void) strncpy(token,".LE.",(*ntok=3)+1);
			else if (c == '>')  /* symbol is >= */
				(void) strncpy(token,".GE.",(*ntok=3)+1);
			else --nbuf;        /* was only an = sign */
			}
		else if (c == '<')          /* Less than symbol */
			(void) strncpy(token,".LT.",(*ntok=3)+1);
		else if (c == '>')          /* Greater than symbol */
			(void) strncpy(token,".GT.",(*ntok=3)+1);
		else if (c =='&')           /* AND symbol */
			(void) strncpy(token,".AND.",(*ntok=4)+1);
		else if (c == '\\')        /* RATMAC \ (OR) symbol */
			(void) strncpy(token,".OR.",(*ntok=3)+1);
		else if (c == '!')          /* NOT symbol */
			(void) strncpy(token,".NOT.",(*ntok=4)+1);
		}
	else {				    /* ntok != 0	*/
		if (c == ':') {             /* char is a macro name flag */
			*type = Macro;           /* type 2 is a macro token */
			if (strncmp(token,"SYSTEMHEADER:",*ntok+1)==0) {
				for (i =nbuf;i<=BUFMAX;i++) /* get title */
					if (ibuf[i] == ',' || ibuf[i] ==')') 
						break;  /* end of macro */
				if (ibuf[i] == ')')  /* get subroutine name*/
				  (void)sprintf(prog,"%.*s",i-nbuf-2,&ibuf[nbuf+2]);
				}
			}
		else if (token[0] != '\'') { /* empty string */
			--nbuf;
			--*ntok;
			}
		else *type = Alphanum;       /* default token type ?? */
		}

}  /* end of subroutine GETTOK */


/* Subroutine OUTSTR */
void outstr(int l1,char  *string,int nstr,int l2)
{
static	int	icnt ;
static	int	ocnt ;
	int     lab1 = l1;         /* Fortran line number */
	int     lab2 = l2;         /* GOTO Fortran line number */
	int     n    = 1;
	int	l;
        int     pcent;
	int	out_fline; /*not outputting a line of FORTRAN code*/

	if (strncmp(string,"GOTO",4)== 0 && strncmp(&obuf[6],"GOTO",4)==0) return; /* do nothing */

	for( ; ; ) {
		out_fline = FALSE;
		if (num_fchars == 7 &&  lab1 != CONC ) num_fchars = 1;
		if (lab1 != CONC && num_fchars == 1) {     /* assume to output line */
			num_fchars = 7;                /* Set fortran pagination */
			(void)strncpy(obuf,"      ",6); /* set first six chars blank*/
			if (lab1 > CONC) (void) sprintf(obuf,"%-6d",lab1); /* encode line number */
			else if (lab1 == CONT) obuf[5] = '&';  /* second pass - line continuation*/
			else if (lab1 == NEW || lab1 == DIGIT) {  /* preformatted fortran code ?*/
				(void) strncpy(obuf,string,nstr+1); /* copy source to output*/
				n = nstr + 2;                    /* chars to output */
				if (lab1 == NEW) num_fchars = n;  /* code -2 ????? */
				}
			lab1 = CONC;                      /* reset fortran line number */
			}
		else if (lab1 != CONC ) out_fline = TRUE; /* set flag to output line */

		if (!out_fline && nstr+1 >= n) {	    /* output line, more than 0 chars*/
			l = min(nstr+1 - n, MAXOUT - num_fchars);
			(void) strncpy(&obuf[num_fchars-1],&string[n-1],(l+1)); /* copy string */
			n += l+1;		  /* increment string pointer */
			num_fchars +=  l+1;	  /* increment output char numb */
			if (num_fchars > MAXOUT) { /* line exceeds FORTRAN pagination*/
				out_fline= TRUE;   /* set flag to output line */
				lab1 = CONT;         /* set flag for line continuation */
				}
			}

		/* process second statement label */
		if (!out_fline && lab2 != 0 ) {	    /* outputing DO & GOTO line numbers*/
			if (lab2 > 0 && (num_fchars+4 <MAXOUT)) {
				(void)sprintf(&obuf[num_fchars-1],"%5d",lab2);
				num_fchars += 5;   /* output 5 character line numbers*/
				lab2 = 0;          /* reset number flag */
				continue;          /* next iteration */
				}
			else if (lab2 > 0) lab1 = CONT;  /* flag for line continuation */
			else if (lab2 < 0) lab2 = CONC;  /* flush buffer on error */
			out_fline = TRUE;              /* definitely printing line*/
			}

		/* if at end of a FORTRAN subroutine */
		if (num_fchars == 10 && strncmp(&obuf[7],"END",3)==0) out_fline = TRUE;
		
		if (!out_fline || num_fchars == 1) return;   /* Do nothing - no output*/
		++olin;               /* increase count of Fort lines ouput*/
		--num_fchars;         /* get number of chars for printing */

		/* Dump a line of FORTRAN to the output file */
		(void) fprintf(Fort_Output,"%-*.*s\n",
				num_fchars,num_fchars,obuf); /*output the line*/
       fflush(Fort_Output);

		if (num_fchars == 9 && strncmp(&obuf[6],"END",3)==0) {	/* end of subroutine*/
			if (nbrc != 0 ) error(16," ",0);     /* test for closed brackets */
			if (ndat != 1000) error(19," ",0);   /* test for datastuff: macro*/

                        pcent= (int)(100 *mtab) / MACTAB_MAX;
			(void) fprintf(RFP_List," %-11sNERR: %4d NRAT: %4d NFTN: %4d NMAC:  %3d MACT: %3d%%\n",
				  prog,nerr,(ilin-icnt),(olin-ocnt),macm,pcent);
fflush(RFP_List);
			(void) printf(" %-11sNERR: %4d NRAT: %4d NFTN: %4d NMAC:  %3d MACT: %3d%%\n",
			      prog,nerr,(ilin-icnt),(olin-ocnt),macm,pcent);
fflush(stdout);
			++llin;
			nert= nert+nerr;  /* total number of errors */
			icnt = ilin;
			ocnt = olin;
			nerr = 0;
			mtab = itab;
			ndat = 1000;
			nbrc = 0;
			macm = nmac;
			nlab = LINE_NUMBER;
			}
		num_fchars = 1;
		} /* repreat */

} /* end of OUTSTR  subroutine */



/* Subroutine EATUP  - ouput string to <;>,<)>, <Endline> */
void eatup(int n, int iflg)
{
	 int   kjk,
	       lpar = 0,
	       npar = 0,
	       nstr = 0,
	       Single_Quotes = FALSE,
		ntok,
		type;
	char   string[4050],
	       c;


	for ( ; ;) {
		macexp(&string[nstr],&type,&ntok);
		if (type == Endfile) break;
		if (type == Endline && Single_Quotes == TRUE) continue;
		if (type == Blank   && Single_Quotes == FALSE) continue;
		if (type == Endline && (n == Ndo || n == Null)) break;
		if (type == Endline ) continue;

		c = string[nstr];
		if (c == '{' || c == '}') {
			--nbuf;
			break;
			}
		if (type == Digraph && (c =='(' || c == ')' )) {
			nbuf -= 2;
			break;
			}
		if (n == Nfor && lpar == 0 && iflg == TAB){  /*a for next loop*/
			if (c != '(') error(02," ",0); /*no bracket after FOR*/
			lpar = 1;
			continue;
			}
		if (c =='"') {                       /* double quote */
			if (Single_Quotes == 0)  Single_Quotes = 1;
			else Single_Quotes = 0;
			string[nstr] = '\'';        /* convert to single quote*/
			}
		else if (type == Digraph) {
			if      (c == 'B') string[nstr] = ' '; /*blank */
			else if (c == 'L') string[nstr] = '('; /*left bracket*/
			else if (c == 'R') string[nstr] = ')'; /*right bracket*/
			}

		if      (c == ';') break;
		else if (c == '(') ++npar;       /* increment num parenth */
		else if (c == ')') --npar;       /* decrement num parenth */
		nstr += ntok+1;
		if (nstr > BUFMAX) error(18," ",0);/* excessive line expansn */
		if (npar < 0)	  break;	 /* too many right parenth */
		if (npar == 0 && (n==Nif || n==Nwhile) ) break; /*end of IF ()*/
		}				     /* end of MACEXP loop */
	
	if (npar > 0)             error(06," ",0); /* too many left parenth */
	if (npar < 0 && n != Nfor)error(07," ",0); /* too many right parenth */
	if (Single_Quotes == 1)   error(15," ",0); /* unclosed quotes */

	if (iflg == SAVE) {   /* Test if <for-reinit.> */
		++nfor;
		forstk[nfor] = ifor;
		kjk = nstr -1;
		if (ifor + kjk >= BUFMAX) error(18,string,kjk);
		(void) strncpy(&forstr[ifor],string,kjk);
		ifor += kjk ;
		}
	else if (nstr > 0) outstr(iflg,string,nstr-1,0);

} /* end of EATUP subroutine */



/* Subroutine PUTMAC */
/* Used to store the fully expanded macros in the macrotable */
/* along with pointers to the macro identifier and corresponding code*/
void putmac(char *macs, int lnam, int ldef, int *npnt)
{
	int     i,j=0,m,n=0,
		macrolength;      /* actual length of the macro */

				/* remove blanks from macro string */  
	while (lnam > 0 && macs[lnam-1] == ' ') {
		for (i=0;i<=ldef;++i)  macs[lnam+i-1] = macs[lnam+i];
	       --lnam;
		}

	if (lnam < 1) {		 /* zero length name definition */
		*npnt = 0;        /* flag as null and return */
		return;
		}

	if (*npnt >= 0 && macs[lnam-1] != ':') error(8," ",0);
	i = lnam-2 ;
	m = macs[i]-47;        /* integer equivalent of last char in name */
	   
	*npnt = macind[m];     /* index based upon last char in macro name */

	if (ldef >= 0 || *npnt > 0) {        /* non null def */
		n = 0;
		while (*npnt != 0) {
			n = *npnt;
			if (lnam != macnam[*npnt]) {  /* inequivalent name length*/
				*npnt=macnex[*npnt];  /* get next of same index*/
				continue;
				}
			j = macadr[*npnt];            /* address in macro table */
			if (strncmp(macs,&mactab[j],lnam)==0) break;
			/* identified correct macro name - else get next */
			*npnt=macnex[*npnt];          /* point to next of same index*/
			}
		}

	if (ldef < 0)  return;      /* no definition - return with *npnt */

	if (*npnt > 0) {          /* a previously defined macro */
		if (ldef <=macdef[*npnt]) {   /* redefine def */
			macdef[*npnt] = ldef; /* redefine length of def */
			(void) strncpy(&mactab[j],macs,lnam+ldef); /*copy new*/
			}
		else {
			n = *npnt;              /* initiallise last in list */
			*npnt = 0;              /* reset  pointer */ 
			macnam[n] = 0;          /* reset length of name */
			while (macnex[n] != 0) n=macnex[n] ; /*get last */
			}
		}

	if (*npnt == 0 ) {        /* defining a new macro */
		
		if (++nmac > MACRO_LIMIT) error(20," ",0); /*too many macros*/
		
		if (n > 0) macnex[n] = nmac;      /* add to end of index list*/
		if (macind[m] == 0) macind[m] = nmac; /* make first if no others*/
		macrolength = lnam + ldef;	 /* actual number of chars */
		if (itab + macrolength > MACTAB_MAX)  error(9," ",0);

		macadr[nmac] = itab+1;        /* pointer to locat in mactab*/
		macnam[nmac] = lnam;          /* store length of name */
		macdef[nmac] = ldef;          /* store length of definition*/
		(void) strncpy(&mactab[itab+1],macs,macrolength);  /* copy chars */
		itab += macrolength ;          /* update pointer to last ch*/
		if (itab > mtab) mtab = itab;  /* save pointer to last macro*/
		if (nmac > macm) macm = nmac;  /* save maximum macro number*/
		}

} /* end of putmac */


/* Subroutine  SYSMAC*/
void _far sysmac(int iarg, int istr)
{
	char	c,d,
		head[41] = " NMAC  IMAC          NAME  DEFINITION   ",
		temp[BUFMAX+1];
	static	char	 code[11];
	static	int	 codf;	    /* assume initialized to 0 */
	int	h,i,j,k,kj,l,m,n,
		na=-1;

	int	nn[10] = {0};

	int	*n1 = nn,
		*n2 = &nn[1],
		*n3 = &nn[2],
		*n4 = &nn[3],
		*n5 = &nn[4];
/*		*n6 = &nn[5];  */

	for (i=iarg+1;i <= narg;i++) {
		++na;
		nn[na]= argstk[i];
		if (na == 10) break;
		}

	c = macstr[istr];
	if (c == 'A') {
		for(kj=*n1+1;kj<=*n2;kj++) {
			if (strchr("0123456789 -+",macstr[kj]) == (char *)0)
				error(21,&macstr[*n1+1],*n2-*n1);
			}
		for (kj=*n3+1;kj<=*n4;kj++) {
			if (strchr("0123456789 -+",macstr[kj]) == (char *)0)
				error(21,&macstr[*n3+1],*n4-*n3);
			}
		(void)sprintf(temp,"%.*s",*n2-*n1,&macstr[*n1+1]); /*copy&delimit*/
		(void)sscanf(temp,"%d",&i);	  /* read integer from string*/
		(void)sprintf(temp,"%.*s",*n4-*n3,&macstr[*n3+1]); /*copy&delimit*/
		(void)sscanf(temp,"%d",&j);	  /* read integer from string*/
		d = macstr[*n2+1];
		k = *n2+2;
		if (d == '+') n = i+j;
		else if (d == '-') n = i -j;
		else if (d == '/' && j != 0) n = i/j;
		else if (d == '*') {
			if (macstr[k] != '*') n = i*j;
			else                  n = (int) pow(i,j);
			}
		else error(13," ",0);

		(void) sprintf(temp,"%d",n);	 /* encode number n left justify */
		l= strlen(temp);         /* !!!!! watch out here ! */
		if (l > 0) {
			nbuf -=  l;
			if (nbuf <= 0) error(18,temp,l);
			(void) strncpy(&ibuf[nbuf+1],temp,l);
			}
		}
	else if (c == 'M') putmac(&macstr[*n1+1],*n2-*n1,*n3-*n2,&n);
	else if (c == 'X') {
		putmac(&macstr[*n1+1],*n2-*n1,-1,&n);
		if (n > 0) macnam[n] = 0;
		else error(11,&macstr[*n1+1],*n2-*n1);
		if (n== nmac) {
			i = n;
			while (i >0 && macnam[i] > 0) --i;
			for (j=1;j<=nmac;j++)
				if (macnex[j] > i) macnex[j] = 0;
			for (j=1;j<=64;j++)
				if (macind[j] > i) macind[j] = 0;
			nmac = i;
			itab = macadr[i+1];
			}
		}
	else if (c == 'I') {
		m = 0;
		if (*n2-*n1 == *n3-*n2) {
			if (*n1 == *n3) m = 1;
			else if (strncmp(&macstr[*n1+1],&macstr[*n2+1],*n2-*n1) == 0) m=1;
			}
		if (m > 0) {
			if (*n4-*n3 > 0) {
				nbuf = nbuf - (*n4-*n3);
				if (nbuf <= 0) error(18,&macstr[*n3+1],*n4-*n3);
				(void)strncpy(&ibuf[nbuf+1],&macstr[*n3+1],*n4-*n3);
				}
			}
		else {
			if (*n5 - *n4 > 0) {
				nbuf = nbuf - (*n5-*n4);    /* val req -1 */
				if (nbuf<= 0) error(18,&macstr[*n4+1],*n5-*n4);
				(void)strncpy(&ibuf[nbuf+1],&macstr[*n4+1],*n5-*n4);
				}
			}
		}
	else if (c == '+') {		/* increment macro arg by one*/
		for (kj = *n1+1 ; kj <= *n2; kj++){
			if (strchr("0123456789 -+",macstr[kj]) == (char *)0)
				error(21,&macstr[*n1+1],*n2-*n1);
			}
		(void) sprintf(temp,"%.*s",*n2-*n1,&macstr[*n1+1]); /*copy&delimit*/
		(void) sscanf(temp,"%d",&i);	  /* read integer from string*/
		(void) sprintf(temp,"%d",i+1);  /* encode number i+1  */
		if ( (n=strlen(temp)) > 0 ) {
			nbuf -=  n;
			if (nbuf <= 0) error(18,temp,n);
			(void) strncpy(&ibuf[nbuf+1],temp,n);
			}
		}
	else if (c == '-') {		   /*decrement macro arg by one */
		for (kj=*n1+1;kj<=*n2;kj++){
			if (strchr("0123456789 -+",macstr[kj]) == (char *)0)
				error(21,&macstr[*n1+1],*n2-*n1);
			}
		(void) sprintf(temp,"%.*s",*n2-*n1,&macstr[*n1+1]); /*copy&delimit*/
		(void) sscanf(temp,"%d",&i);	  /* read integer from string*/
		(void) sprintf(temp,"%d",i-1);  /* encode number i-1	*/
		if ( (n=strlen(temp)) > 0 ) {
			nbuf -=  n;
			if (nbuf <= 0) error(18,temp,n);
			(void) strncpy(&ibuf[nbuf+1],temp,n);
			}
		}
	else if (c =='C') {	       /*convert ascii num vals to chars*/
		for (kj=*n1+1;kj<=*n2;kj++){
			if (strchr("0123456789 -+",macstr[kj]) == (char *)0)
				error(21,&macstr[*n1+1],*n2-*n1);
			}
		(void) sprintf(temp,"%.*s",*n2-*n1,&macstr[*n1+1]); /*copy&delimit*/
		(void) sscanf(temp,"%d",&i);	 /* read integer value */
		*temp = (char) i;	/* convert integer i to character */
		if (--nbuf <= 0) error(18,temp,1);
		(void) strncpy(&ibuf[nbuf+1],temp,1);  /* copy char */
		}
	else if (c == 'O') {		  /* ord macro */
		i = macstr[*n1+1];	  /* get digit */
		(void) sprintf(temp,"%d",i);    /* encode number i left justify */
		if ( (n=strlen(temp)) > 0) {
			nbuf -=  n;
			if (nbuf <= 0) error(18,temp,n);
			(void) strncpy(&ibuf[nbuf+1],temp,n);
			}
		}
	else if (c == 'S') {		 /* substr: macro */
		n = *n2-*n1;
		for (kj=*n2+1;kj<=*n3;kj++){
			if (strchr("0123456789 -+",macstr[kj]) == (char *)0)
				error(21,&macstr[*n2+1],*n3-*n2);
			}
		(void) sprintf(temp,"%.*s",*n3-*n2,&macstr[*n2+1]); /*copy&delimit*/
		(void) sscanf(temp,"%d",&i);
		if (i < 1 || i > n) j = 0;
		else if (*n4 > 0 ) {
			for (kj=*n3+1;kj<=*n4;kj++){
				if (strchr("0123456789 -+",macstr[kj]) == (char *)0)
					error(21,&macstr[*n3+1],*n4-*n3);
				}
			(void) sprintf(temp,"%.*s",*n4-*n3,&macstr[*n3+1]); /*copy&delimit*/
			(void) sscanf(temp,"%d",&j);
			}
		else j = n-i + 1;
		i = *n1 + i -1;
		if ( j > 0) {
			nbuf -= j;
			if (nbuf <= 0 ) error(18,&macstr[i],j);
			(void) strncpy(&ibuf[nbuf+1],macstr,j);
			}
		 }
	else if (c == 'Y' || c == 'N'){
		if (c =='Y') n = TRUE;
		else         n = FALSE;
		d = macstr[*n1+1];
		if      (d == 'S') flags = n;
		else if (d == 'R') flagr = n;
		else if (d == 'D') flagd = n;
		else error(14," ",0);
		outstr(0," ",0,-1);
		}
	else if (c == 'P') {
		putmac(&macstr[*n1+1],*n2-*n1,-1,&n);
		if ( n == 0) error(11,&macstr[*n1+1],*n2-*n1);
		for (j=1;j<=nmac;j++) if (macnex[j] > n) macnex[j] = 0;
		for (j=1;j<=64  ;j++) if (macind[j] > n) macind[j] = 0;
		nmac = n;
		itab= macadr[n+1];
		}
	else  if (c =='D') {
		putmac(&macstr[*n1+1],*n2-*n1,-1,&n);
		if ( n == 0) n = 1;
		putmac(&macstr[*n2+1],*n3-*n2,-1,&l);
		if ( l == 0)  l = nmac;
		(void) fprintf(RFP_List,"%40s\n",head);
		for ( ;n <= l;n++ ) {                /* dump macro listing*/
			(void) sprintf(temp,"%5d%6d%15.*s ",
				n,macadr[n],macnam[n],&mactab[macadr[n]]);
			j = macadr[n] +1;            /* macro adress in mactab*/
			i = macdef[n];               /* length of definition*/
			while (i >= 0 ) {
				(void) sprintf(&temp[28],"%*s\n",min(i,70),&mactab[j]);
				 ++llin;
				if (llin > 80) {
					llin = 3;
					(void) fprintf(RFP_List,"\n%40s\n",head);
					}
				(void) fprintf(RFP_List,temp);  /* print macro def */
				for(h=0;h<27;h++)temp[h]=' ';/* 27 blanks */
				j = j+70;
				i = i -70;
				}   /* end of while */
			}           /* end of for */
		}                   /* end of else if */
	else if (c =='E') {
		i = *n2-*n1;
		j = *n3-*n2;
		n = -1; /* strip quotes from string */
		if (macstr[*n2+1] =='\'' || macstr[*n2+1]=='\"' ) {
			(void) strncpy(temp,&macstr[*n2+2],j);
			(void) strncpy(&macstr[*n2+1],temp,*n3-*n2);
			j -= 2;
			}
		putmac(&macstr[*n1+1],i,j,&n);
		ndat = min(ndat,nmac);
		(void) sprintf(temp,"INTEGERN%.*s",i,&macstr[*n1+1]);
		outstr(-1,temp,i+8-1,0);
		(void) sprintf(temp,"CHARACTER*%-6d%.*s",j,i,&macstr[*n1+1]);
		outstr(-1,temp,i+16-1,0);
		}
	else if (c == 'G' || c == 'H' || c == 'J') {
		i = *n2-*n1;
		j = *n3-*n2;
		n = -1;
		(void) sprintf(temp,"%-.*s/%-.*s",i,&macstr[*n1+1],j,&macstr[*n2+1]);
		putmac(temp,i,j+1,&n);	     /*i,j may be 1 too large */
		ndat = min(ndat,nmac);
		n = 1;
		j = j+ *n2;

		while (*n2 < j ) {
			if (macstr[*n2+1] == ',') ++n;
			++*n2;
			}
		if	(c == 'G') (void) sprintf(temp,"REAL            %-.*s",i,&macstr[*n1+1]);
		else if (c == 'H') (void) sprintf(temp,"INTEGER         %-.*s",i,&macstr[*n1+1]);
		else		   (void) sprintf(temp,"DOUBLE PRECISION%-.*s",i,&macstr[*n1+1]);
		if (n > 1) {
			(void) sprintf(&temp[i+16],"(%-3d)",n);
			outstr(-1,temp,i+20,0);
			}
		else outstr(-1,temp,i+15,0);
		}
	else if (c == 'F' && ndat < 1000) {  /* dump data types from macro tab*/
		for(n=ndat;n<=nmac;n++){
			i = macnam[n];
			j = macadr[n];
			l = macdef[n];
			if (mactab[i+j] == '/') { /* numeric array*/
				(void) sprintf(temp,"DATA%.*s/",i+l,&mactab[j]);
				outstr(TAB,temp,i+l+4,0);
				}
			else {                  /* character array */
				(void) sprintf(temp,"DATAN%-.*s/%-3d/, %.*s/\'%.*s\'/", 
				  i,&mactab[j],l,i,&mactab[j],l,&mactab[i+j]);
				outstr(TAB,temp,i+i+12+l+3,0);
				}
			}
		for (j=1;j<=nmac;j++) if (macnex[j] >= ndat) macnex[j]=0;
		for (j=1;j<=64;j++) if (macind[j] >= ndat) macind[j]=0;
		nmac = ndat -1;
		itab = macadr[ndat];
		ndat = 1000;
		}
	else if (c == 'R') {
		i = *n2-*n1;
		j = *n3-*n2;
		(void) sprintf(temp,"CHARACTER*(%-6.*s)%-.*s",j,
			&macstr[*n2+1],i,&macstr[*n1+1]);
		outstr(-1,temp,i+17,0);
		}
	else if (c == 'U'){
		if (macstr[*n1+1] == '\''){ /*file name enclosed in parenth */
			(void) strncpy(temp,&macstr[*n1+2],*n2-2-*n1);
			(void) strcpy(&temp[*n2-*n1-2],"");
			}
		else	{
			(void) strncpy(temp,&macstr[*n1+1],*n2-*n1);
			(void) strcpy(&temp[*n2-*n1],"");
			}
		if ((Extrude_File = fopen(temp,"w"))==(FILE *)NULL) {
			(void) fprintf(stdout,"unable to open file: %8s",temp);
			exit(-10);
			}
		Extrude_Flag = TRUE;
		}
	else if (c == 'V') {
		fclose(Extrude_File);
		Extrude_Flag = FALSE;
		}
	else if (c == 'Q') {
		(void) sprintf(code,"          ");	  /* erase code */
		(void) strncpy(code,&macstr[*n1+1],*n2-*n1);
		}
	else if (c == 'Z') {		     /*ifsel: macro */
		if (codf == 0) {
			for (i=0;i <=na;i++) {
				n = nn[i];
				m = nn[i+1];
				j = m - n;
				if (j <= 0) break;
				if (strncmp(code,&macstr[n+1],j)== 0) break;
				}
			if (i < na) codf = 1;
			else        accf = 0;
			}
		else accf = 0;
		}
	else if (c == 'W') codf = 0;

}

/* Subroutine  ERROR */
void error(int ierr,char *name,int m)
{
	char      *mess[21] = { "max <INCLUDE> files exceeded  ",
				"<FOR> MUST be followed by <(> ",
				"<NEXT>,<BREAK> not in a loop  ",
				"BRACES are not balanced       ",
				"stack overflow - incr. maxstk:",
				"too many LEFT parentheses     ",
				"too many RIGHT parentheses    ",
				"macro NAME is now redefined   ",
				"macro TABLE has been exceeded ",
				"max size of TOKEN exceeded    ",
				"invoked macro not defined     ",
				"macro definition incomplete   ",
				"illegal arith: operator       ",
				"unrecognized flagon/off: code ",
				"quoted string is incomplete   ",
				"braces imbalanced at END line ",
				"illegal <ELSE-IF> construction",
				"line expansion exceeds maxbuf:",
				"datastuff: missing in program ",
				"macro overflow - incr. maxmac:",
				"macro arg. must be numeric    " };

	int     n;

	n = min(m,14);
	++llin;
	(void) fprintf(RFP_List,"ERROR in line %6d  %30s %*s\n",
		ilin,mess[ierr-1], n, name);
	(void) fprintf(stdout,"ERROR in line %6d  %29s %*s\n",
		ilin,mess[ierr-1], n, name);
	++nerr;
	if (ierr == 1 || ierr == 5 || ierr == 9 || ierr == 10 || ierr == 18 ||
		ierr == 20 || ierr == 12 || ierr == 21) {
		outstr(0," ",0,-1);
		exit(1);
		}
}