|
|
end
c---------------------------------------------------------------------
subroutine freeread(line,rea,nrea)
c---------------------------------------------------------------------
c
c Reads a line input and breaks it into smaller segments. it will
c transfer all the real and integers into the rea array in the same
c sequence that they are, and ignore the character strings. in this
c fashion it will allow for easier input than a simple(r) free-format
c reader.
c
implicit double precision(a-h,o-z)
character*(*) line
character*80 form
character*20 fmtstr
integer pointer,nstring,i,is,ie,ief,irea
dimension pointer(160),fmtstr(80)
dimension rea(2)
c
c to clear the FORM string
c
i=1
do while (i.le.len(form))
form(i:i)=' '
i=i+1
end do
c
call segment(line,pointer,fmtstr,form,nstring)
i=1
irea=1
do while (i.le.nstring)
is=pointer(2*i-1)
ie=pointer(2*i)
call limits(fmtstr(i),isf,ief)
if (form(i:i).eq.'f') then
read (line(is:ie),fmt=fmtstr(i)) rea(irea)
irea=irea+1
endif
c
if (form(i:i).eq.'i') then
read (line(is:ie),fmt=fmtstr(i)) integ
rea(irea)=real(integ)
irea=irea+1
endif
c
i=i+1
end do
nrea=irea+1
return
end
c----------------------------------------------------------------------
subroutine segment(line,pointer,fmtstr,form,nstring)
c
c This subroutine takes an input character string ("LINE"), and
c partitions it in its natural segements as separated by blanks.
c the string itself is the only necessary input, and its length
c is determined when called. it returns the line itself, the
c integer array "POINTER" which contains the positions of the
c first and last non-blank characters of each segment, a character
c string "FORM" which contains a one-letter descriptor of the
c data type of each segment (a, i, or f) and "FMTSTR", a charcter
c array containing the string-formats for each segment. the only
c variables limited in its length are fmstr (10 characters for
c each individual format) and "STRING", a temporary storage for
c each individual segment (80 char's).
c
implicit double precision(a-h,o-z)
character*(*) line,form
character*80 string
character*(*) fmtstr
character*1 typ
logical found,num,firstchar,decpoint,exponent
integer iline,istring,nstring,eol,is,ie,ici,pointer
dimension pointer(2),fmtstr(2)
c
call limits(line,iline,eol)
nstring=0
100 if (iline.le.eol) then
string=' '
istring = 1
found=.false.
typ=' '
200 if (line(iline:iline).ne.' ') then
firstchar=.false.
num=.false.
found=.true.
string(istring:istring)=line(iline:iline)
if (typ.eq.' ') then
pointer(2*nstring+1)=iline
exponent=.false.
decpoint=.false.
firstchar=.true.
ici=ichar(line(iline:iline))
if (ici.eq.46) decpoint=.true.
num=(ici.le.57).and.
+ ((ici.ge.48).or.(ici.eq.43).or.(ici.eq.45))
if (num) then
typ = 'i'
else
typ = 'a'
endif
if ((typ.eq.'a').and.decpoint) typ='f'
endif
c
if ((typ.ne.'a').and.(.not.firstchar)) then
ici=ichar(line(iline:iline))
num=(ici.le.57).and.(ici.ge.48)
if ((typ.eq.'i').and.(num)) goto 300
if ((typ.eq.'f').and.(num)) goto 300
c
if (ici.eq.46) then
if (typ.eq.'i') then
decpoint=.true.
typ='f'
goto 300
else
if (decpoint) typ='a'
endif
endif
c
if ((ici.eq.69).or.(ici.eq.68)) then
if (.not.exponent) then
typ='f'
exponent=.true.
icn=ichar(line(iline+1:iline+1))
nxt=(((icn.eq.43).or.(icn.eq.45))
+ .or.((icn.ge.48).and.(icn.le.57)))
if (nxt) then
istring=istring+1
iline=iline+1
string(istring:istring)=line(
+ iline:iline)
goto 300
else
typ='a'
endif
else
typ='a'
endif
endif
typ='a'
endif
c
300 iline=iline+1
istring=istring+1
goto 200
endif
if (found) then
pointer(2*nstring+2)=iline-1
is=pointer(2*nstring+1)
ie=pointer(2*nstring+2)
nstring = nstring + 1
form(nstring:nstring)=typ
call findformat(line(is:ie),is,ie,
+ form(nstring:nstring),fmtstr(nstring))
endif
iline=iline+1
goto 100
endif
return
end
c-------------------------------------------------------------------------
subroutine findformat(word,first,last,type,rtf)
c
c this subroutine finds the format needed to read a "word". the size
c of this string is not numerically limited, but determined when the
c subroutine is called. it needs as input "type", a one-character
c string describing the type (a, i, or f), the string itself
c ("word"), and its limits ("first" and "last"). it will return
c the format ("rtf") as a string.
c
implicit double precision(a-h,o-z)
character*1 type
character*2 lstr,dstr
character*(*) rtf
character*(*) word
integer first,last,len,dec
len=last-first+1
write (lstr,'(i2)') len
c
if (type.ne.'f') then
if (len.ge.10) then
rtf='('//type//lstr(1:2)//')'
else
rtf='('//type//lstr(2:2)//')'
endif
endif
c
if (type.eq.'f') then
dec=len-index(word,'.')
if ((dec.eq.len).and.(index(word,'e').ne.0))
+ dec=len-index(word,'e')
write (dstr,'(i2)') dec
if (len.ge.10) then
if (dec.ge.10) then
rtf='('//type//lstr(1:2)//'.'//dstr(1:2)//')'
else
rtf='('//type//lstr(1:2)//'.'//dstr(2:2)//')'
endif
else
if (dec.ge.10) then
rtf='('//type//lstr(2:2)//'.'//dstr(1:2)//')'
else
rtf='('//type//lstr(2:2)//'.'//dstr(2:2)//')'
endif
endif
endif
return
end
c ---------------------------------------------------------------------
subroutine limits(str,first,last)
c
c this subroutine finds the "first" and the "last" non-blank
c charcters in the string "str". the length of the string is not
c numerically limited, but its length is determined when called.
c "i" and "ib" are the forward and backward counters.
c
implicit double precision(a-h,o-z)
character*(*) str
integer first,last,i,ib
first = 0
last=0
do 1 i=1,len(str)
if (first.eq.0) then
if (str(i:i).ne.' ') first = i
endif
c
if (last.eq.0) then
ib=len(str)-i
if (str(ib:ib).ne.' ') last = ib
endif
1 continue
return
end
|
