* Copyright (c) 1980 Regents of the University of California.
* All rights reserved. The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
LOCAL
char var_name
[VL
+1];
#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)
{ 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
;
struct namelistentry
*entry
;
nml_rd
= "namelist read";
fmtbuf
= "ext namelist io";
if(n
=c_le(a
,READ
)) return(n
);
if(curunit
->uwrt
&& ! nowreading(curunit
)) err(errflag
, errno
, nml_rd
)
/* look for " &namelistname " */
nmlist_nm
= a
->namelist
->namelistname
;
/* 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 */
if( GETC
!= *nmlist_nm
++ )
nml_rd
= "incorrect namelist name";
if(!isblnk(GETC
)) goto rderr
;
while( GETC
!= namelistkey_
)
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
;
nml_rd
= "incorrect variable name";
if( n
= get_pars( entry
, &addr
, &nelem
, &vlen
, &vtype
))
if(ch
!= '=') goto rderr
;
if(n
= l_read( nelem
, addr
, vlen
, vtype
)) goto rderr_n
;
if(ch
== ',') while(isblnk(GETC
));
/* check for 'end' after '&' or '$'*/
if(GETC
!='e' || GETC
!='n' || GETC
!='d' )
/* flush to next input record */
while(GETC
!= '\n' && ch
!= EOF
);
return(ch
== EOF
? EOF
: OK
);
if(n
== EOF
) err(endflag
,EOF
,nml_rd
);
/* flush after error in case restart I/O */
if(ch
!= '\n') while(GETC
!= '\n' && ch
!= EOF
) ;
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 */
*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 */
switch ( *vtype
= entry
->type
) {
fatal(F_ERSYS
,"unknown type in rsnmle");
/* get number of elements */
/* get element length, number of dimensions, base, span vector */
if(ndim
<=0 || ndim
>MAXSUBS
) fatal(F_ERSYS
,"illegal dimensions");
/* get subscripts from input data */
if( ++subcnt
> MAXSUBS
-1 ) return F_ERNMLIST
;
if(n
=get_int(&subs
[subcnt
])) return n
;
if(ch
!= ',' && ch
!= ')') return F_ERNMLIST
;
if( ++subcnt
!= ndim
) return F_ERNMLIST
;
for( i
= ndim
-2; i
>=0; i
-- )
offset
= subs
[i
] + span
[i
]*offset
;
*nelem
= dimptr
[1] - offset
;
if( offset
< 0 || offset
>= dimptr
[1] )
*addr
= *addr
+ (*vlen
)*offset
;
int sign
=0, value
=0, cnt
=0;
if(GETC
== '-') sign
= -1;
if(ch
== EOF
) return(EOF
);
value
= 10*value
+ ch
-'0';
if(ch
== EOF
) return EOF
;
if(cnt
== 0 ) return F_ERNMLIST
;
if(sign
== -1) value
= -value
;
/* read a variable name from the input stream */
if(ptr
-init
> VL
) return(ERROR
);
if(ch
== '\n') newline
= YES
;
{ /* skip first character on each line for namelist */
l_read(number
,ptr
,len
,type
) ftnint number
,type
; flex
*ptr
; ftnlen len
;
if(ch
!= ',' ) return(F_ERNMLIST
);
if(i
!=0 && ch
== namelistkey_
) return(OK
);
if(!isint(ch
)) return(OK
);
if(!isrl(ch
)) return(OK
);
if(!isdigit(ch
) && ch
!='(') return(OK
);
if(!islgc(ch
)) return(OK
);
if(!isdigit(ch
) && !isapos(ch
)) return(OK
);
/* peek at next character -
should be separator or namelistkey_ */
if(!issep(ch
) && (ch
!= namelistkey_
))
return( leof
?EOF
:F_ERNMLIST
);
if(!ltype
) return(F_ERNMLIST
);
b_char(lchar
,(char *)ptr
,len
);
ptr
= (flex
*)((char *)ptr
+ len
);
if(lcount
>0) return F_ERNMLIST
;
da
=rd_int(&a
); /* repeat count ? */
if (a
<= 0.) return(F_ERNREP
);
db
=rd_int(&b
); /* whole part of number */
if(GETC
=='.' && isdigit(GETC
))
dc
=rd_int(&c
); /* fractional part of number */
dd
=rd_int(&d
); /* exponent */
else if (ch
== '+' || ch
== '-')
for(i
=0;i
<dc
;i
++) c
/=10.;
{ for(i
=0;i
<d
;i
++) b
*= 10.;
for(i
=0;i
< -d
;i
++) b
/= 10.;
return(y
==0.0?sign
:i
); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
if(n
=get_repet()) return(n
); /* get repeat count */
if(GETC
!='(') err(errflag
,F_ERNMLIST
,"no (")
l_R(0); /* get real part */
while(isblnk(GETC
)); /* get comma */
if(ch
!=',') return(F_ERNMLIST
);
l_R(0); /* get imag part */
if(ch
!=')') err(errflag
,F_ERNMLIST
,"no )")
int n
, keychar
=ch
, scanned
=NO
;
if(ch
=='f' || ch
=='F' || ch
=='t' || ch
=='T')
return(leof
?EOF
:F_ERNMLIST
);
if(ch
== '=' || ch
== '(')
{ /* found a name, not a value */
if(n
=get_repet()) return(n
); /* get repeat count */
else err(errflag
,F_ERNMLIST
,"logical not T or F");
while(!issep(GETC
) && ch
!=EOF
) ;
if(ch
== EOF
) return(EOF
);
if(n
=get_repet()) return(n
); /* get repeat count */
if(isapos(GETC
)) quote
=ch
;
else if(ch
== EOF
) return EOF
;
if(lchar
!=NULL
) free(lchar
);
p
=lchar
=(char *)malloc(BUFSIZE
);
if(lchar
==NULL
) return (F_ERSPACE
);
{ while( GETC
!=quote
&& ch
!='\n' && ch
!=EOF
&& ++i
<size
)
lchar
=(char *)realloc(lchar
, size
+1);
if(lchar
==NULL
) return( F_ERSPACE
);
else if(ch
==EOF
) return(EOF
);
{ if(*(p
-1) == '\\') *(p
-1) = ch
;
{ if(++i
<size
) *p
++ = ch
;