c<html>
c<head><title>charvar.f</title></head>
c<body>
c<pre>
Program charvar
c
c Demonstrate use of character variables
c Everything in this program is Fortran 77, and all of the
c essentials are demonstrated at least once.
c
c John Mahaffy, 2/7/96
c
implicit none
integer nwords,nwin
parameter (nwords=10)
character*80 line
character keyword(nwords)*16, tform*8
real value(nwords)
c
c line - character string to contain one line of input
c keyword - a character array containing keywords to determine
c variable assignments
c value - a character array containing values associated with
c keywords
c nwords - maximum number of entries in arrays "keyword" and "value"
c nwin - actual number of entries in arrays "keyword" and "value"
c tform - character string to contain the format for Temperatures
c
c Get some information from a file (first executable statement)
c
call input (nwords,line,keyword,value,nwin,tform)
c
c Process the contents of "line"
c
call doline(line)
c
c I could use this routine to work on any character
c string
c
call doline ('This string can be parsed')
c
c Process the kewords and associated values
c
call props ( keyword, value, nwin, tform)
c
stop
end
c
c
c
subroutine input(nwords,line,keyword,value,nwin,tform)
c
c Open an input file and read some information
c
c John Mahaffy 3/8/95
c
implicit none
integer nwords,nwin, nstring, nget, inerr, ioerr, ierr
parameter (nget=2)
integer istring(nget), ndigits, ispace, nline
character string(nget)*16 , tform*(*)
c
c The subroutine doesn't need to be told the length of the character
c variables, the information is passed without your knowing it. This
c gives your subroutine the power to work on character strings with
c many different lengths.
c
character*(*) line
character keyword(nwords)*(*)
real value(nwords)
c
character fname*16, answer*8, inline*80
logical fexist
c
c Arguments
c
c Input -
c nwords - size of the keyword and value character arrays
c
c Output -
c line - character string to contain one line of input
c keyword - a character array containing keywords to determine
c variable assignments
c value - a character array containing values associated with
c keywords
c nwin - actual number of entries in arrays "keyword" and "value"
c tform - character string to contain the format for Temperatures
c
c Other important variables
c number - character representation of the value associated with
c the keyword
c fname - name of file containing input
c inline - contains an input line with a keyword, value pair
c string - array containing contiguous character strings from inline
c istring- array giving starting location of corresponding element in
c string within inline
c nget - number of strings to get from inline
c nstring- number of strings actually found in inline
c inerr - keep track of fatal input errors
c ioerr - flag error on real numbers
c nline - current line number within the input file
c
c Begin executable code by opening the I/O units
c
5 write(*,1000)
1000 format ( 'Provide name of the input file:')
read *, fname
write(*,*)
c <a name="inquire"><font color="FF0000">
inquire (file=fname,exist=fexist)
c </font></a>
if (.not.fexist) then
write(*, *) fname,' does not exist'
write(*, *) 'Do you want to quit (yes or no)?'
read (*,1001) answer
if (answer(1:1).eq.'y'.or.answer(1:1).eq.'Y') stop
go to 5
endif
open (11,file=fname,status='old',err=600)
read(11,1001,end=602) line
inerr= 0
nline=1
do 30 nwin=1,nwords
c
c The 1001 in the next line is necessary. Try a '*' and see what
c happens.
c
10 read (11,1001,end=40) inline
nline=nline+1
call parsl (inline,string,nget,nstring,istring,ierr)
c
c Detect fatal errors, but don't quit yet
c
if (ierr.ne.0) then
write(*, *) 'Problem is in line ',nline
write(*, *)
inerr=inerr+1
endif
if ( nstring.lt. nget) then
if (nstring.le.0) go to 10
write(*, *) 'Insufficient information in line ',nline
$ , ' :'
write(*, *) inline
write(*, *)
inerr=inerr+1
endif
c
c
c When numerous case combinations are possible and
c relational tests will be used, it is a good idea
c to internally convert keyword strings to a single
c case
c
call upper (string(1))
keyword(nwin)=string(1)
c
c Put the input value (character string) into a real
c variable
c <a name="read"><font color="FF0000">
read(string(2),'(e16.5)',iostat=ioerr) value(nwin)
c </font></a>
if (ioerr.ne.0) then
inerr=inerr+1
ispace= index(string(2),' ') - 1
write(*, *) 'Error interpreting : ',string(2)(1:ispace),
$ ' as a real number in line ', nline
write(*, *)
endif
30 continue
c
c Check if remaining lines are blank or comments
c
35 read (11,1001,end=40) inline
if(inline.eq.' ') go to 35
ispace = index(inline ,'!')
if (ispace.ne.0) then
if( inline(1:(ispace-1)).eq.' ') go to 35
endif
write(*, *) 'More than ',nwords, 'keywords. Rest ignored'
write(*,*) 'Recompile with a larger value for the parameter',
& ' nwords'
c
c Done reading the file. Wrap up and deal with errors
c
40 nwin=nwin-1
if (nwin.le.0) then
write(*,*) 'No Keyword information in the input deck'
inerr=inerr+1
endif
if(inerr.gt.0) then
write(*, *) inerr,' Fatal Input Errors on Unit 11, Quiting Now'
stop
endif
write(*,2000)
read(*,'(i5)') ndigits
write(*,*)
c<a name=1><font color=FF0000>
ndigits=min(9,max(0,ndigits))
c</font>
ispace=ndigits+6
write(tform,1002) ispace,ndigits
return
c
600 write(*, *)'Problem opening file: ', fname
stop
602 write(*, *) ' No Data in the Input File'
stop
1001 format (a)
1002 format ('f',i2,'.',i1)
2000 format (' Number of digits you want printed after the',
$ ' decimal for Temperatures: ')
end
c
c
c
subroutine upper(string)
c
c Convert lower case to upper case.
c This is one good use of ichar and char intrinsic functions
c
c John Mahaffy 3/8/96
c
character string*(*)
c<a name=3><font color=FF0000>
lc=len(string)
c</font>
icdiff=ichar('A')-ichar('a')
do 10 i=1,lc
if(string(i:i).lt.'a'.or.string(i:i).gt.'z') go to 10
c
c shift lower case to upper case
c
string(i:i)=char(ichar(string(i:i))+icdiff)
10 continue
return
end
c
c
c
subroutine doline(line)
c
c processrate use of character variables
c Everything in this program is Fortran 77
c
c John Mahaffy 3/8/96
c
implicit none
integer nwords, nwmax, i, ihigh, ilow, ierr, lline, loline
parameter (nwmax=5)
character*(*) line
character*80 oline
character words(nwmax)*16 , form1*16
integer lwords(nwmax)
c
c INPUT
c line - A line containing characters
c OTHER IMPORTANT Variables
c
c words - array containing contiguous character strings from line
c lwords - array giving starting location of corresponding element in
c words within line, later used to contain word length
c nwmax - maximum number of strings to get from line
c nstring- number of strings actually found in line
c
c Begin Executable Code
c
lline=len(line)
call parsl (line,words,nwmax,nwords,lwords,ierr)
if (ierr.ne.0) then
write(*, *) 'Word length exceeded in line 1'
endif
write(*, *)
write(*, *) 'Original First Line'
write(*, *) line
c
c Note that you can't reassemble the line neatly by printing the
c words directly
c
loline=len(oline)
oline=words(1)//words(2)//words(3)//words(4)//words(5)
write(*, *) 'Direct combination of Parsed Words from the Line'
write(*,2000) oline
c
c However, you have enough information to do a good job of
c reassembly
c
ihigh=0
oline=' '
do 20 i=1,nwords
lwords(i)= index( words(i), ' ') - 1
if(lwords(i).lt.0) lwords(i)=16
c<a name=2><font color=FF0000>
ilow=min(ihigh+1,loline)
ihigh=min(ihigh+lwords(i)+1 ,loline)
c</font>
20 oline(ilow:ihigh)=words(i)(1:lwords(i))//' '
write(*, *)
write(*, *) ' Reconstructed line'
write(*,2000) oline
write(form1,2001) nwmax
c
c You can also reconstruct the line with a write statement
c
write(*,form1) (words(i)(1:lwords(i)),i=1,nwords)
return
2000 format (a)
2001 format ('(',i3,'(a,'' ''))')
end
c
c
c
subroutine parsl (line,sym,nfnd,nsym,isym,ierr)
c
c Separate the individual words in the line for
c later interpretation. This action is commonly
c called "parsing".
c
c John Mahaffy 3/8/95
c
c This is a good example of how not to program. Notice how the
c tangle of GO TO Statements make interpretation of the subroutine
c nearly impossible. It is also an example of the advantages of
c subroutines. I wrote the core of this subroutine shortly after
c the advent of Fortran 77, applying old Fortran 66 habits. Whenever
c I've needed to parse a line since then, I've dug this out and
c plugged it into my program with little or no modifications.
c
c INPUT
c line - line to be parsed
c sym - array containing individual words in the line
c nfnd - number of words desired from the line
c OUTPUT
c nsym - number of words found in the line
c isym - array containing the starting location of each word
c ierr - error flag set if any words are too long
c OTHER important variables
c lline - actual size of line as set in the calling routine
c lsym - actual number of characters allowed for each word
c
dimension isym(*)
character line*(*),sym(*)*(*)
lsym=len(sym(1))
lline=len(line)
nsym=0
ierr=0
do 10 i=1,nfnd
10 sym(i)=' '
i=1
j=1
c
c Space, equals, and comma are considered word separators here
c An exclamation point ends processing of the line (rest ignored)
c
20 if(i.gt.lline) go to 80
if(line(i:i).eq.' '.or.line(i:i).eq.'='.or.
& line(i:i).eq.',' ) go to 24
if(line(i:i).eq.'!') go to 80
go to 30
24 i=i+1
j=1
new=1
go to 20
30 if (1.lt.j) go to 40
if(sym(nsym).eq.'!') go to 80
nsym=nsym+1
isym(nsym)=i
if(nsym.gt.nfnd) go to 80
40 if (lsym.lt.j) go to 55
sym(nsym)(j:j)=line(i:i)
i=i+1
j=j+1
go to 20
55 ierr=1
write(*,2002) lsym
2002 format(' This word has more than',i3,' characters')
call poinat(line,9,i)
il=i+1
do 60 i=il,lline
if(line(i:i).eq.' '.or.line(i:i).eq.'='.or.
$ line(i:i).eq.',') go to 24
60 continue
80 return
c
end
c
c
c
subroutine poinat(line,nw,ic)
c
c Write line and a pointer under character ic.
c
character line*80
character f*40
icm=ic-1
write(f,2000) icm
2000 format('(',i3,'x,''^'')')
write(*,2020)line
2020 format(/(1x,a80))
write(*,f)
return
end
c
c
c
subroutine props ( keyword, value, nwin, tform)
c
c Do something with all of the keywords. The basic
c fuctionality of this keyword based input is captured
c in the Fortran NAMELIST structure. However, NAMELIST
c was a nonstandard extension of Fortran 77 (now standard
c in Fortran 90), and NAMELIST has less flexiblity in
c error processing.
c
implicit none
integer nwin, i
character keyword(nwin)*(*),tform*8, form1*40
real t,p,rho,rg, value(nwin)
parameter (rg=287.0478)
data t,p,rho/3*0.0/
c
c keyword - a character array containing keywords to determine
c variable assignments
c value - a character array containing values associated with
c keywords
c nwin - actual number of entries in arrays "keyword" and "value"
c tform - character string to contain the format for Temperatures
c
form1 ='( '' Temperature = '','//tform //','' K'')'
write(*, *)
do 100 i=1,nwin
if (keyword(i).eq.'T'.or.keyword(i).eq.'TEMP'.or.keyword(i)
$ .eq.'TEMPERATURE') then
t=value(i)
write(*,form1) t
else if (keyword(i).eq.'P'.or.keyword(i).eq.'PRES'
$ .or.keyword(i).eq.'PRESSURE') then
p=value(i)
write(*,2001) p
else
write(*,2002) i
write(*,'(a)') keyword(i)
write(*,*)
endif
100 continue
c
c Normally variables set from this type of processing would be
c passed back through the argument list, or through a COMMON
c block. I'll just do a quick calculation here to at least
c say that they were put to use.
c
rho=p/(rg*t)
write(*,2003) rho
c
return
2001 format ( ' Pressure = ',1p,e10.3,' Pa')
2002 format (/, ' I can''t recognize keyword number ',i3)
2003 format ( ' Density based on last T and P is: ',1p,e10.3,
$ ' kg/m**3')
end
c </pre>
c </body>
c </html>
c
Copyright ©2017 - STI - Todos os direitos reservados