usr/src/usr.bin/f77/libI77/rsnmle.c

/*
 * Copyright (c) 1980 Regents of the University of California.
 * All rights reserved.  The Berkeley software License Agreement
 * specifies the terms and conditions for redistribution.
 *
 *	@(#)rsnmle.c	5.4	%G%
 */

/*
 *		name-list read
 */

#include "fio.h"
#include "lio.h"
#include "nmlio.h"
#include <ctype.h>

LOCAL char *nml_rd;

static int ch;
LOCAL nameflag;
LOCAL	char var_name[VL+1];

#define SP 1
#define B  2
#define AP 4
#define EX 8
#define INTG 16
#define RL 32
#define LGC 64
#define IRL 		(INTG | RL | LGC )
#define isblnk(x)	(ltab[x+1]&B)	/* space, tab, newline */
#define issep(x)	(ltab[x+1]&SP)	/* space, tab, newline, comma */
#define isapos(x)	(ltab[x+1]&AP)	/* apost., quote mark */
#define isexp(x)	(ltab[x+1]&EX)	/* d, e, D, E */
#define isint(x)	(ltab[x+1]&INTG)	/* 0-9, plus, minus */
#define isrl(x)		(ltab[x+1]&RL)	/* 0-9, plus,  minus, period */
#define islgc(x)	(ltab[x+1]&LGC)	/* 0-9, period, t, f, T, F */

#define GETC (ch=t_getc())
#define UNGETC() ungetc(ch,cf)

LOCAL char *lchar;
LOCAL double lx,ly;
LOCAL int ltype;
int t_getc(), ungetc();

LOCAL char ltab[128+1] =
{			0, 		/* offset one for EOF */
/*   0- 15 */ 0,0,0,0,0,0,0,0,0,SP|B,SP|B,0,0,0,0,0, /* TAB,NEWLINE */
/*  16- 31 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
/*  32- 47 */ SP|B,0,AP,0,0,0,0,AP,0,0,0,RL|INTG,SP,RL|INTG,RL|LGC,0, /* space,",',comma,., */
/*  48- 63 */ IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,0,0,0,0,0,0, /* digits */
/*  64- 79 */ 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0,	/* D,E,F */
/*  80- 95 */ 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0,	/* T */
/*  96-111 */ 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0,	/* d,e,f */
/* 112-127 */ 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0		/* t */
};

s_rsne(a) namelist_arglist *a;
{
	int n;
	struct namelistentry *entry;
	int nelem, vlen, vtype;
	char *nmlist_nm, *addr;

	nml_rd = "namelist read";
	reading = YES;
	formatted = NAMELIST;
	fmtbuf = "ext namelist io";
	if(n=c_le(a,READ)) return(n);
	getn = t_getc;
	ungetn = ungetc;
	leof = curunit->uend;
	if(curunit->uwrt && ! nowreading(curunit)) err(errflag, errno, nml_rd)

	/* look for " &namelistname " */
	nmlist_nm = a->namelist->namelistname;
	while(isblnk(GETC)) ;
	/* check for "&end" (like IBM) or "$end" (like DEC) */
	if(ch != '&' && ch != '$') goto rderr;
	/* save it - write out using the same character as used on input */
	namelistkey_ = ch;
	while( *nmlist_nm )
		if( GETC != *nmlist_nm++ )
			{
				nml_rd = "incorrect namelist name";
				goto rderr;
			}
	if(!isblnk(GETC)) goto rderr;
	while(isblnk(GETC)) ;
	if(leof) goto rderr;
	UNGETC();

	while( GETC != namelistkey_ )
	{
	    UNGETC();
	    /* get variable name */
	    if(!nameflag && rd_name(var_name)) goto rderr;

	    entry = a->namelist->names;
	    /* loop through namelist entries looking for this variable name */
	    while( entry->varname[0] != 0 )
	    {
		if( strcmp(entry->varname, var_name) == 0 ) goto got_name;
		entry++;
	    }
	    nml_rd = "incorrect variable name";
	    goto rderr;
got_name:
	    if( n = get_pars( entry, &addr, &nelem, &vlen, &vtype ))
							goto rderr_n;
	    while(isblnk(GETC)) ;
	    if(ch != '=') goto rderr;

	    nameflag = NO;
	    if(n = l_read( nelem, addr, vlen, vtype )) goto rderr_n;
	    while(isblnk(GETC));
	    if(ch == ',') while(isblnk(GETC));
	    UNGETC();
	    if(leof) goto rderr;
	}
	/* check for 'end' after '&' or '$'*/
	if(GETC!='e' || GETC!='n' || GETC!='d' )
		goto rderr;
	/* flush to next input record */
flush:
	while(GETC != '\n' && ch != EOF);
	return(ch == EOF ? EOF : OK);

rderr:
	if(leof)
		n = EOF;
	else
		n = F_ERNMLIST;
rderr_n:
	if(n == EOF ) err(endflag,EOF,nml_rd);
	/* flush after error in case restart I/O */
	if(ch != '\n')  while(GETC != '\n' && ch != EOF) ;
	err(errflag,n,nml_rd)
}

#define MAXSUBS 7

LOCAL
get_pars( entry, addr, nelem, vlen, vtype )
struct namelistentry *entry;
char	**addr;		/* beginning address to read into */
int	*nelem,		/* number of elements to read */
	*vlen,		/* length of elements */
	*vtype;		/* type of elements */
{
	int	offset, i, n,
		*dimptr,	/* points to dimensioning info */
		ndim,		/* number of dimensions */
		baseoffset,	/* offset of corner element */
		*span,		/* subscript span for each dimension */
		subs[MAXSUBS],	/* actual subscripts */
		subcnt = -1;	/* number of actual subscripts */


	/* get element size and base address */
	*vlen = entry->typelen;
	*addr = entry->varaddr;

	/* get type */
	switch ( *vtype = entry->type ) {
		case TYSHORT:
		case TYLONG:
		case TYREAL:
		case TYDREAL:
		case TYCOMPLEX:
		case TYDCOMPLEX:
		case TYLOGICAL:
		case TYCHAR:
			break;
		default:
		    fatal(F_ERSYS,"unknown type in rsnmle");
	}

	/* get number of elements */
	dimptr = entry->dimp;
	if( dimptr==NULL )
	{		/* scalar */
		*nelem = 1;
		return(OK);
	}

	if( GETC != '(' )
	{		/* entire array */
		*nelem = dimptr[1];
		UNGETC();
		return(OK);
	}

	/* get element length, number of dimensions, base, span vector */
	ndim = dimptr[0];
	if(ndim<=0 || ndim>MAXSUBS) fatal(F_ERSYS,"illegal dimensions");
	baseoffset = dimptr[2];
	span = dimptr+3;

	/* get subscripts from input data */
	while(ch!=')') {
		if( ++subcnt > MAXSUBS-1 ) return F_ERNMLIST;
		if(n=get_int(&subs[subcnt])) return n;
		GETC;
		if(leof) return EOF;
		if(ch != ',' && ch != ')') return F_ERNMLIST;
	}
	if( ++subcnt != ndim ) return F_ERNMLIST;

	offset = subs[ndim-1];
	for( i = ndim-2; i>=0; i-- )
		offset = subs[i] + span[i]*offset;
	offset -= baseoffset;
	*nelem = dimptr[1] - offset;
	if( offset < 0 || offset >= dimptr[1] )
		return F_ERNMLIST;
	*addr = *addr + (*vlen)*offset;
	return OK;
}

LOCAL
get_int(subval)
int *subval;
{
	int sign=0, value=0, cnt=0;

	/* look for sign */
	if(GETC == '-') sign = -1;
	else if(ch == '+') ;
	else UNGETC();
	if(ch == EOF) return(EOF);

	while(isdigit(GETC))
	{
		value = 10*value + ch-'0';
		cnt++;
	}
	UNGETC();
	if(ch == EOF) return EOF;
	if(cnt == 0 ) return F_ERNMLIST;
	if(sign== -1) value = -value;
	*subval = value;
	return OK;
}

LOCAL
rd_name(ptr)
char *ptr;
{
	/* read a variable name from the input stream */
	char *init = ptr-1;

	if(!isalpha(GETC)) {
		UNGETC();
		return(ERROR);
	}
	*ptr++ = ch;
	while(isalnum(GETC))
	{
		if(ptr-init > VL ) return(ERROR);
		*ptr++ = ch;
	}
	*ptr = '\0';
	UNGETC();
	return(OK);
}

LOCAL
t_getc()
{	int ch;
	static newline = YES;
rd:
	if(curunit->uend) {
		leof = EOF;
		return(EOF);
	}
	if((ch=getc(cf))!=EOF)
	{
		if(ch == '\n') newline = YES;
		else if(newline==YES)
		{	/* skip first character on each line for namelist */
			newline = NO;
			goto rd;
		}
		return(ch);
	}
	if(feof(cf))
	{	curunit->uend = YES;
		leof = EOF;
	}
	else clearerr(cf);
	return(EOF);
}

LOCAL
l_read(number,ptr,len,type) ftnint number,type; flex *ptr; ftnlen len;
{	int i,n;
	double *yy;
	float *xx;

	lcount = 0;
	for(i=0;i<number;i++)
	{
		if(leof) return EOF;
		if(lcount==0)
		{
			ltype = NULL;
			if(i!=0)
			{	/* skip to comma */
				while(isblnk(GETC));
				if(leof) return(EOF);
				if(ch == namelistkey_)
				{	UNGETC();
					return(OK);
				}
				if(ch != ',' ) return(F_ERNMLIST);
			}
			while(isblnk(GETC));
			if(leof) return(EOF);
			UNGETC();
			if(i!=0 && ch == namelistkey_) return(OK);

			switch((int)type)
			{
			case TYSHORT:
			case TYLONG:
				if(!isint(ch)) return(OK);
				ERRNM(l_R(1));
				break;
			case TYREAL:
			case TYDREAL:
				if(!isrl(ch)) return(OK);
				ERRNM(l_R(1));
				break;
			case TYCOMPLEX:
			case TYDCOMPLEX:
				if(!isdigit(ch) && ch!='(') return(OK);
				ERRNM(l_C());
				break;
			case TYLOGICAL:
				if(!islgc(ch)) return(OK);
				ERRNM(l_L());
				if(nameflag) return(OK);
				break;
			case TYCHAR:
				if(!isdigit(ch) && !isapos(ch)) return(OK);
				ERRNM(l_CHAR());
				break;
			}

			if(leof) return(EOF);
 			/* peek at next character -
				should be separator or namelistkey_ */
 			GETC; UNGETC();
			if(!issep(ch) && (ch != namelistkey_))
			return( leof?EOF:F_ERNMLIST );
		}

		if(!ltype) return(F_ERNMLIST);
		switch((int)type)
		{
		case TYSHORT:
			ptr->flshort=lx;
			break;
		case TYLOGICAL:
			if(len == sizeof(short))
				ptr->flshort = lx;
			else
				ptr->flint = lx;
			break;
		case TYLONG:
			ptr->flint=lx;
			break;
		case TYREAL:
			ptr->flreal=lx;
			break;
		case TYDREAL:
			ptr->fldouble=lx;
			break;
		case TYCOMPLEX:
			xx=(float *)ptr;
			*xx++ = ly;
			*xx = lx;
			break;
		case TYDCOMPLEX:
			yy=(double *)ptr;
			*yy++ = ly;
			*yy = lx;
			break;
		case TYCHAR:
			b_char(lchar,(char *)ptr,len);
			break;
		}
		if(lcount>0) lcount--;
		ptr = (flex *)((char *)ptr + len);
	}
	if(lcount>0) return F_ERNMLIST;
	return(OK);
}

LOCAL
get_repet()
{
	double lc;
	if(isdigit(GETC))
	{	UNGETC();
		rd_int(&lc);
		lcount = (int)lc;
		if(GETC!='*')
			if(leof) return(EOF);
			else return(F_ERREPT);
	}
	else
	{	lcount = 1;
		UNGETC();
	}
	return(OK);
}

LOCAL
l_R(flg) int flg;
{	double a,b,c,d;
	int da,db,dc,dd;
	int i,sign=0;
	a=b=c=d=0;
	da=db=dc=dd=0;

	if( flg )		/* real */
	{
		da=rd_int(&a);	/* repeat count ? */
		if(GETC=='*')
		{
			if (a <= 0.) return(F_ERNREP);
			lcount=(int)a;
			db=rd_int(&b);	/* whole part of number */
		}
		else
		{	UNGETC();
			db=da;
			b=a;
			lcount=1;
		}
	}
	else		   /* complex */
	{
		db=rd_int(&b);
	}

	if(GETC=='.' && isdigit(GETC))
	{	UNGETC();
		dc=rd_int(&c);	/* fractional part of number */
	}
	else
	{	UNGETC();
		dc=0;
		c=0.;
	}
	if(isexp(GETC))
		dd=rd_int(&d);	/* exponent */
	else if (ch == '+' || ch == '-')
	{	UNGETC();
		dd=rd_int(&d);
	}
	else
	{	UNGETC();
		dd=0;
	}
	if(db<0 || b<0)
	{	sign=1;
		b = -b;
	}
	for(i=0;i<dc;i++) c/=10.;
	b=b+c;
	if (dd > 0)
	{	for(i=0;i<d;i++) b *= 10.;
		for(i=0;i< -d;i++) b /= 10.;
	}
	lx=sign?-b:b;
	ltype=TYLONG;
	return(OK);
}

LOCAL
rd_int(x) double *x;
{	int sign=0,i=0;
	double y=0.0;
	if(GETC=='-') sign = -1;
	else if(ch=='+') sign=0;
	else UNGETC();
	while(isdigit(GETC))
	{	i++;
		y=10*y + ch-'0';
	}
	UNGETC();
	if(sign) y = -y;
	*x = y;
	return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
}

LOCAL
l_C()
{	int n;
	if(n=get_repet()) return(n);		/* get repeat count */
	if(GETC!='(') err(errflag,F_ERNMLIST,"no (")
	while(isblnk(GETC));
	UNGETC();
	l_R(0);		/* get real part */
	ly = lx;
	while(isblnk(GETC));  /* get comma */
	if(leof) return(EOF);
	if(ch!=',') return(F_ERNMLIST);
	while(isblnk(GETC));
	UNGETC();
	if(leof) return(EOF);
	l_R(0);		/* get imag part */
	while(isblnk(GETC));
	if(ch!=')') err(errflag,F_ERNMLIST,"no )")
	ltype = TYCOMPLEX;
	return(OK);
}

LOCAL
l_L()
{
	int n, keychar=ch, scanned=NO;
	if(ch=='f' || ch=='F' || ch=='t' || ch=='T')
	{
		scanned=YES;
		if(rd_name(var_name))
			return(leof?EOF:F_ERNMLIST);
		while(isblnk(GETC));
		UNGETC();
		if(ch == '=' || ch == '(')
		{  	/* found a name, not a value */
			nameflag = YES;
			return(OK);
		}
	}
	else
	{
		if(n=get_repet()) return(n);		/* get repeat count */
		if(GETC=='.') GETC;
		keychar = ch;
	}
	switch(keychar)
	{
	case 't':
	case 'T':
		lx=1;
		break;
	case 'f':
	case 'F':
		lx=0;
		break;
	default:
		if(ch==EOF) return(EOF);
		else	err(errflag,F_ERNMLIST,"logical not T or F");
	}
	ltype=TYLOGICAL;
	if(scanned==NO)
	{
		while(!issep(GETC) && ch!=EOF) ;
		UNGETC();
	}
	if(ch == EOF ) return(EOF);
	return(OK);
}

#define BUFSIZE	128
LOCAL
l_CHAR()
{	int size,i,n;
	char quote,*p;
	if(n=get_repet()) return(n);		/* get repeat count */
	if(isapos(GETC)) quote=ch;
	else if(ch == EOF) return EOF;
	else return F_ERNMLIST;
	ltype=TYCHAR;
	if(lchar!=NULL) free(lchar);
	size=BUFSIZE-1;
	p=lchar=(char *)malloc(BUFSIZE);
	if(lchar==NULL) return (F_ERSPACE);
	for(i=0;;)
	{	while( GETC!=quote && ch!='\n' && ch!=EOF && ++i<size )
				*p++ = ch;
		if(i==size)
		{
		newone:
			size += BUFSIZE;
			lchar=(char *)realloc(lchar, size+1);
			if(lchar==NULL) return( F_ERSPACE );
			p=lchar+i-1;
			*p++ = ch;
		}
		else if(ch==EOF) return(EOF);
		else if(ch=='\n')
		{	if(*(p-1) == '\\') *(p-1) = ch;
		}
		else if(GETC==quote)
		{	if(++i<size) *p++ = ch;
			else goto newone;
		}
		else
		{	UNGETC();
			*p = '\0';
			return(OK);
		}
	}
}
Commit	Line	Data
	1	/*
	2	* Copyright (c) 1980 Regents of the University of California.
	3	* All rights reserved. The Berkeley software License Agreement
	4	* specifies the terms and conditions for redistribution.
	5	*
	6	* @(#)rsnmle.c 5.4 %G%
	7	*/
	8
	9	/*
	10	* name-list read
	11	*/
	12
	13	#include "fio.h"
	14	#include "lio.h"
	15	#include "nmlio.h"
	16	#include <ctype.h>
	17
	18	LOCAL char *nml_rd;
	19
	20	static int ch;
	21	LOCAL nameflag;
	22	LOCAL char var_name[VL+1];
	23
	24	#define SP 1
	25	#define B 2
	26	#define AP 4
	27	#define EX 8
	28	#define INTG 16
	29	#define RL 32
	30	#define LGC 64
	31	#define IRL (INTG \| RL \| LGC )
	32	#define isblnk(x) (ltab[x+1]&B) /* space, tab, newline */
	33	#define issep(x) (ltab[x+1]&SP) /* space, tab, newline, comma */
	34	#define isapos(x) (ltab[x+1]&AP) /* apost., quote mark */
	35	#define isexp(x) (ltab[x+1]&EX) /* d, e, D, E */
	36	#define isint(x) (ltab[x+1]&INTG) /* 0-9, plus, minus */
	37	#define isrl(x) (ltab[x+1]&RL) /* 0-9, plus, minus, period */
	38	#define islgc(x) (ltab[x+1]&LGC) /* 0-9, period, t, f, T, F */
	39
	40	#define GETC (ch=t_getc())
	41	#define UNGETC() ungetc(ch,cf)
	42
	43	LOCAL char *lchar;
	44	LOCAL double lx,ly;
	45	LOCAL int ltype;
	46	int t_getc(), ungetc();
	47
	48	LOCAL char ltab[128+1] =
	49	{ 0, /* offset one for EOF */
	50	/* 0- 15 / 0,0,0,0,0,0,0,0,0,SP\|B,SP\|B,0,0,0,0,0, / TAB,NEWLINE */
	51	/* 16- 31 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	52	/* 32- 47 / SP\|B,0,AP,0,0,0,0,AP,0,0,0,RL\|INTG,SP,RL\|INTG,RL\|LGC,0, / space,",',comma,., */
	53	/* 48- 63 / IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,0,0,0,0,0,0, / digits */
	54	/* 64- 79 / 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0, / D,E,F */
	55	/* 80- 95 / 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0, / T */
	56	/* 96-111 / 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0, / d,e,f */
	57	/* 112-127 / 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0 / t */
	58	};
	59
	60	s_rsne(a) namelist_arglist *a;
	61	{
	62	int n;
	63	struct namelistentry *entry;
	64	int nelem, vlen, vtype;
	65	char nmlist_nm, addr;
	66
	67	nml_rd = "namelist read";
	68	reading = YES;
	69	formatted = NAMELIST;
	70	fmtbuf = "ext namelist io";
	71	if(n=c_le(a,READ)) return(n);
	72	getn = t_getc;
	73	ungetn = ungetc;
	74	leof = curunit->uend;
	75	if(curunit->uwrt && ! nowreading(curunit)) err(errflag, errno, nml_rd)
	76
	77	/* look for " &namelistname " */
	78	nmlist_nm = a->namelist->namelistname;
	79	while(isblnk(GETC)) ;
	80	/* check for "&end" (like IBM) or "$end" (like DEC) */
	81	if(ch != '&' && ch != '$') goto rderr;
	82	/* save it - write out using the same character as used on input */
	83	namelistkey_ = ch;
	84	while( *nmlist_nm )
	85	if( GETC != *nmlist_nm++ )
	86	{
	87	nml_rd = "incorrect namelist name";
	88	goto rderr;
	89	}
	90	if(!isblnk(GETC)) goto rderr;
	91	while(isblnk(GETC)) ;
	92	if(leof) goto rderr;
	93	UNGETC();
	94
	95	while( GETC != namelistkey_ )
	96	{
	97	UNGETC();
	98	/* get variable name */
	99	if(!nameflag && rd_name(var_name)) goto rderr;
	100
	101	entry = a->namelist->names;
	102	/* loop through namelist entries looking for this variable name */
	103	while( entry->varname[0] != 0 )
	104	{
	105	if( strcmp(entry->varname, var_name) == 0 ) goto got_name;
	106	entry++;
	107	}
	108	nml_rd = "incorrect variable name";
	109	goto rderr;
	110	got_name:
	111	if( n = get_pars( entry, &addr, &nelem, &vlen, &vtype ))
	112	goto rderr_n;
	113	while(isblnk(GETC)) ;
	114	if(ch != '=') goto rderr;
	115
	116	nameflag = NO;
	117	if(n = l_read( nelem, addr, vlen, vtype )) goto rderr_n;
	118	while(isblnk(GETC));
	119	if(ch == ',') while(isblnk(GETC));
	120	UNGETC();
	121	if(leof) goto rderr;
	122	}
	123	/* check for 'end' after '&' or '$'*/
	124	if(GETC!='e' \|\| GETC!='n' \|\| GETC!='d' )
	125	goto rderr;
	126	/* flush to next input record */
	127	flush:
	128	while(GETC != '\n' && ch != EOF);
	129	return(ch == EOF ? EOF : OK);
	130
	131	rderr:
	132	if(leof)
	133	n = EOF;
	134	else
	135	n = F_ERNMLIST;
	136	rderr_n:
	137	if(n == EOF ) err(endflag,EOF,nml_rd);
	138	/* flush after error in case restart I/O */
	139	if(ch != '\n') while(GETC != '\n' && ch != EOF) ;
	140	err(errflag,n,nml_rd)
	141	}
	142
	143	#define MAXSUBS 7
	144
	145	LOCAL
	146	get_pars( entry, addr, nelem, vlen, vtype )
	147	struct namelistentry *entry;
	148	char *addr; / beginning address to read into */
	149	int nelem, / number of elements to read */
	150	vlen, / length of elements */
	151	vtype; / type of elements */
	152	{
	153	int offset, i, n,
	154	dimptr, / points to dimensioning info */
	155	ndim, /* number of dimensions */
	156	baseoffset, /* offset of corner element */
	157	span, / subscript span for each dimension */
	158	subs[MAXSUBS], /* actual subscripts */
	159	subcnt = -1; /* number of actual subscripts */
	160
	161
	162	/* get element size and base address */
	163	*vlen = entry->typelen;
	164	*addr = entry->varaddr;
	165
	166	/* get type */
	167	switch ( *vtype = entry->type ) {
	168	case TYSHORT:
	169	case TYLONG:
	170	case TYREAL:
	171	case TYDREAL:
	172	case TYCOMPLEX:
	173	case TYDCOMPLEX:
	174	case TYLOGICAL:
	175	case TYCHAR:
	176	break;
	177	default:
	178	fatal(F_ERSYS,"unknown type in rsnmle");
	179	}
	180
	181	/* get number of elements */
	182	dimptr = entry->dimp;
	183	if( dimptr==NULL )
	184	{ /* scalar */
	185	*nelem = 1;
	186	return(OK);
	187	}
	188
	189	if( GETC != '(' )
	190	{ /* entire array */
	191	*nelem = dimptr[1];
	192	UNGETC();
	193	return(OK);
	194	}
	195
	196	/* get element length, number of dimensions, base, span vector */
	197	ndim = dimptr[0];
	198	if(ndim<=0 \|\| ndim>MAXSUBS) fatal(F_ERSYS,"illegal dimensions");
	199	baseoffset = dimptr[2];
	200	span = dimptr+3;
	201
	202	/* get subscripts from input data */
	203	while(ch!=')') {
	204	if( ++subcnt > MAXSUBS-1 ) return F_ERNMLIST;
	205	if(n=get_int(&subs[subcnt])) return n;
	206	GETC;
	207	if(leof) return EOF;
	208	if(ch != ',' && ch != ')') return F_ERNMLIST;
	209	}
	210	if( ++subcnt != ndim ) return F_ERNMLIST;
	211
	212	offset = subs[ndim-1];
	213	for( i = ndim-2; i>=0; i-- )
	214	offset = subs[i] + span[i]*offset;
	215	offset -= baseoffset;
	216	*nelem = dimptr[1] - offset;
	217	if( offset < 0 \|\| offset >= dimptr[1] )
	218	return F_ERNMLIST;
	219	addr = addr + (vlen)offset;
	220	return OK;
	221	}
	222
	223	LOCAL
	224	get_int(subval)
	225	int *subval;
	226	{
	227	int sign=0, value=0, cnt=0;
	228
	229	/* look for sign */
	230	if(GETC == '-') sign = -1;
	231	else if(ch == '+') ;
	232	else UNGETC();
	233	if(ch == EOF) return(EOF);
	234
	235	while(isdigit(GETC))
	236	{
	237	value = 10*value + ch-'0';
	238	cnt++;
	239	}
	240	UNGETC();
	241	if(ch == EOF) return EOF;
	242	if(cnt == 0 ) return F_ERNMLIST;
	243	if(sign== -1) value = -value;
	244	*subval = value;
	245	return OK;
	246	}
	247
	248	LOCAL
	249	rd_name(ptr)
	250	char *ptr;
	251	{
	252	/* read a variable name from the input stream */
	253	char *init = ptr-1;
	254
	255	if(!isalpha(GETC)) {
	256	UNGETC();
	257	return(ERROR);
	258	}
	259	*ptr++ = ch;
	260	while(isalnum(GETC))
	261	{
	262	if(ptr-init > VL ) return(ERROR);
	263	*ptr++ = ch;
	264	}
	265	*ptr = '\0';
	266	UNGETC();
	267	return(OK);
	268	}
	269
	270	LOCAL
	271	t_getc()
	272	{ int ch;
	273	static newline = YES;
	274	rd:
	275	if(curunit->uend) {
	276	leof = EOF;
	277	return(EOF);
	278	}
	279	if((ch=getc(cf))!=EOF)
	280	{
	281	if(ch == '\n') newline = YES;
	282	else if(newline==YES)
	283	{ /* skip first character on each line for namelist */
	284	newline = NO;
	285	goto rd;
	286	}
	287	return(ch);
	288	}
	289	if(feof(cf))
	290	{ curunit->uend = YES;
	291	leof = EOF;
	292	}
	293	else clearerr(cf);
	294	return(EOF);
	295	}
	296
	297	LOCAL
	298	l_read(number,ptr,len,type) ftnint number,type; flex *ptr; ftnlen len;
	299	{ int i,n;
	300	double *yy;
	301	float *xx;
	302
	303	lcount = 0;
	304	for(i=0;i<number;i++)
	305	{
	306	if(leof) return EOF;
	307	if(lcount==0)
	308	{
	309	ltype = NULL;
	310	if(i!=0)
	311	{ /* skip to comma */
	312	while(isblnk(GETC));
	313	if(leof) return(EOF);
	314	if(ch == namelistkey_)
	315	{ UNGETC();
	316	return(OK);
	317	}
	318	if(ch != ',' ) return(F_ERNMLIST);
	319	}
	320	while(isblnk(GETC));
	321	if(leof) return(EOF);
	322	UNGETC();
	323	if(i!=0 && ch == namelistkey_) return(OK);
	324
	325	switch((int)type)
	326	{
	327	case TYSHORT:
	328	case TYLONG:
	329	if(!isint(ch)) return(OK);
	330	ERRNM(l_R(1));
	331	break;
	332	case TYREAL:
	333	case TYDREAL:
	334	if(!isrl(ch)) return(OK);
	335	ERRNM(l_R(1));
	336	break;
	337	case TYCOMPLEX:
	338	case TYDCOMPLEX:
	339	if(!isdigit(ch) && ch!='(') return(OK);
	340	ERRNM(l_C());
	341	break;
	342	case TYLOGICAL:
	343	if(!islgc(ch)) return(OK);
	344	ERRNM(l_L());
	345	if(nameflag) return(OK);
	346	break;
	347	case TYCHAR:
	348	if(!isdigit(ch) && !isapos(ch)) return(OK);
	349	ERRNM(l_CHAR());
	350	break;
	351	}
	352
	353	if(leof) return(EOF);
	354	/* peek at next character -
	355	should be separator or namelistkey_ */
	356	GETC; UNGETC();
	357	if(!issep(ch) && (ch != namelistkey_))
	358	return( leof?EOF:F_ERNMLIST );
	359	}
	360
	361	if(!ltype) return(F_ERNMLIST);
	362	switch((int)type)
	363	{
	364	case TYSHORT:
	365	ptr->flshort=lx;
	366	break;
	367	case TYLOGICAL:
	368	if(len == sizeof(short))
	369	ptr->flshort = lx;
	370	else
	371	ptr->flint = lx;
	372	break;
	373	case TYLONG:
	374	ptr->flint=lx;
	375	break;
	376	case TYREAL:
	377	ptr->flreal=lx;
	378	break;
	379	case TYDREAL:
	380	ptr->fldouble=lx;
	381	break;
	382	case TYCOMPLEX:
	383	xx=(float *)ptr;
	384	*xx++ = ly;
	385	*xx = lx;
	386	break;
	387	case TYDCOMPLEX:
	388	yy=(double *)ptr;
	389	*yy++ = ly;
	390	*yy = lx;
	391	break;
	392	case TYCHAR:
	393	b_char(lchar,(char *)ptr,len);
	394	break;
	395	}
	396	if(lcount>0) lcount--;
	397	ptr = (flex )((char )ptr + len);
	398	}
	399	if(lcount>0) return F_ERNMLIST;
	400	return(OK);
	401	}
	402
	403	LOCAL
	404	get_repet()
	405	{
	406	double lc;
	407	if(isdigit(GETC))
	408	{ UNGETC();
	409	rd_int(&lc);
	410	lcount = (int)lc;
	411	if(GETC!='*')
	412	if(leof) return(EOF);
	413	else return(F_ERREPT);
	414	}
	415	else
	416	{ lcount = 1;
	417	UNGETC();
	418	}
	419	return(OK);
	420	}
	421
	422	LOCAL
	423	l_R(flg) int flg;
	424	{ double a,b,c,d;
	425	int da,db,dc,dd;
	426	int i,sign=0;
	427	a=b=c=d=0;
	428	da=db=dc=dd=0;
	429
	430	if( flg ) /* real */
	431	{
	432	da=rd_int(&a); /* repeat count ? */
	433	if(GETC=='*')
	434	{
	435	if (a <= 0.) return(F_ERNREP);
	436	lcount=(int)a;
	437	db=rd_int(&b); /* whole part of number */
	438	}
	439	else
	440	{ UNGETC();
	441	db=da;
	442	b=a;
	443	lcount=1;
	444	}
	445	}
	446	else /* complex */
	447	{
	448	db=rd_int(&b);
	449	}
	450
	451	if(GETC=='.' && isdigit(GETC))
	452	{ UNGETC();
	453	dc=rd_int(&c); /* fractional part of number */
	454	}
	455	else
	456	{ UNGETC();
	457	dc=0;
	458	c=0.;
	459	}
	460	if(isexp(GETC))
	461	dd=rd_int(&d); /* exponent */
	462	else if (ch == '+' \|\| ch == '-')
	463	{ UNGETC();
	464	dd=rd_int(&d);
	465	}
	466	else
	467	{ UNGETC();
	468	dd=0;
	469	}
	470	if(db<0 \|\| b<0)
	471	{ sign=1;
	472	b = -b;
	473	}
	474	for(i=0;i<dc;i++) c/=10.;
	475	b=b+c;
	476	if (dd > 0)
	477	{ for(i=0;i<d;i++) b *= 10.;
	478	for(i=0;i< -d;i++) b /= 10.;
	479	}
	480	lx=sign?-b:b;
	481	ltype=TYLONG;
	482	return(OK);
	483	}
	484
	485	LOCAL
	486	rd_int(x) double *x;
	487	{ int sign=0,i=0;
	488	double y=0.0;
	489	if(GETC=='-') sign = -1;
	490	else if(ch=='+') sign=0;
	491	else UNGETC();
	492	while(isdigit(GETC))
	493	{ i++;
	494	y=10*y + ch-'0';
	495	}
	496	UNGETC();
	497	if(sign) y = -y;
	498	*x = y;
	499	return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
	500	}
	501
	502	LOCAL
	503	l_C()
	504	{ int n;
	505	if(n=get_repet()) return(n); /* get repeat count */
	506	if(GETC!='(') err(errflag,F_ERNMLIST,"no (")
	507	while(isblnk(GETC));
	508	UNGETC();
	509	l_R(0); /* get real part */
	510	ly = lx;
	511	while(isblnk(GETC)); /* get comma */
	512	if(leof) return(EOF);
	513	if(ch!=',') return(F_ERNMLIST);
	514	while(isblnk(GETC));
	515	UNGETC();
	516	if(leof) return(EOF);
	517	l_R(0); /* get imag part */
	518	while(isblnk(GETC));
	519	if(ch!=')') err(errflag,F_ERNMLIST,"no )")
	520	ltype = TYCOMPLEX;
	521	return(OK);
	522	}
	523
	524	LOCAL
	525	l_L()
	526	{
	527	int n, keychar=ch, scanned=NO;
	528	if(ch=='f' \|\| ch=='F' \|\| ch=='t' \|\| ch=='T')
	529	{
	530	scanned=YES;
	531	if(rd_name(var_name))
	532	return(leof?EOF:F_ERNMLIST);
	533	while(isblnk(GETC));
	534	UNGETC();
	535	if(ch == '=' \|\| ch == '(')
	536	{ /* found a name, not a value */
	537	nameflag = YES;
	538	return(OK);
	539	}
	540	}
	541	else
	542	{
	543	if(n=get_repet()) return(n); /* get repeat count */
	544	if(GETC=='.') GETC;
	545	keychar = ch;
	546	}
	547	switch(keychar)
	548	{
	549	case 't':
	550	case 'T':
	551	lx=1;
	552	break;
	553	case 'f':
	554	case 'F':
	555	lx=0;
	556	break;
	557	default:
	558	if(ch==EOF) return(EOF);
	559	else err(errflag,F_ERNMLIST,"logical not T or F");
	560	}
	561	ltype=TYLOGICAL;
	562	if(scanned==NO)
	563	{
	564	while(!issep(GETC) && ch!=EOF) ;
	565	UNGETC();
	566	}
	567	if(ch == EOF ) return(EOF);
	568	return(OK);
	569	}
	570
	571	#define BUFSIZE 128
	572	LOCAL
	573	l_CHAR()
	574	{ int size,i,n;
	575	char quote,*p;
	576	if(n=get_repet()) return(n); /* get repeat count */
	577	if(isapos(GETC)) quote=ch;
	578	else if(ch == EOF) return EOF;
	579	else return F_ERNMLIST;
	580	ltype=TYCHAR;
	581	if(lchar!=NULL) free(lchar);
	582	size=BUFSIZE-1;
	583	p=lchar=(char *)malloc(BUFSIZE);
	584	if(lchar==NULL) return (F_ERSPACE);
	585	for(i=0;;)
	586	{ while( GETC!=quote && ch!='\n' && ch!=EOF && ++i<size )
	587	*p++ = ch;
	588	if(i==size)
	589	{
	590	newone:
	591	size += BUFSIZE;
	592	lchar=(char *)realloc(lchar, size+1);
	593	if(lchar==NULL) return( F_ERSPACE );
	594	p=lchar+i-1;
	595	*p++ = ch;
	596	}
	597	else if(ch==EOF) return(EOF);
	598	else if(ch=='\n')
	599	{ if((p-1) == '\\') (p-1) = ch;
	600	}
	601	else if(GETC==quote)
	602	{ if(++i<size) *p++ = ch;
	603	else goto newone;
	604	}
	605	else
	606	{ UNGETC();
	607	*p = '\0';
	608	return(OK);
	609	}
	610	}
	611	}