c<html>
c<head><title>charvar90.f</title></head>
c<body>
c<pre>
Program charvar90
c
c Demonstrate use of character variables
c Features of Fortran 90 are applied, but not all of the
c Fortran 90 intrinsic functions are used.
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, nline
parameter (nget=2)
integer istring(nget), ndigits, ispace
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, blank*2
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 - line number in input file
c
c Begin executable code by opening the I/O units
c
fexist=.false.
do while (.not.fexist)
write(*,1000,advance='no')
1000 format ( 'Provide name of the input file: ')
read *, fname
write(*,*)
inquire (file=fname,exist=fexist)
if (fexist) exit
write(*, *) fname,' does not exist'
write(*, *) 'Do you want to quit (yes or no)?'
read(*,1001) answer
call leftjust (answer)
if (answer(1:1).eq.'y'.or.answer(1:1).eq.'Y') stop
end do
c <a name="open"><font color="FF0000">
open (11,file=fname,status='old',err=600)
c </font></a>
read(11,1001,end=602) line
inerr= 0
nwin=0
nline=1
do while (nwin.lt.nwords)
c
c The 1001 in the next line is necessary. Try a '*' and see what
c happens.
c
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
c<a name="cycle"><font color="FF0000">
if (nstring.le.0) cycle
c</font></a>
write(*, *) 'Problem is in line ',nline
write(*, *)
inerr=inerr+1
endif
if ( nstring.lt. nget) then
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
nwin=nwin+1
call upper (string(1))
keyword(nwin)=string(1)
c
c Put the input value (character string) into a real
c variable
c
c In the past, I've used machines that would require a
c right justification of string(2) prior to the following
c read. Probably not a problem any more.
c <a name=1><font color="FF0000">
c string(2)=adjustr(string(2))
c </font>
c This read takes the character contents of "string(2)" and
c converts them to internal floating point representation in
c the real variable "value"
c
read(string(2),'(e16.5)',iostat=ioerr) value(nwin)
c
if (ioerr.ne.0) then
inerr=inerr+1
write(*, *) 'Error interpreting : ',trim(string(2)),
$ ' as a real number in line ', nline
write(*, *)
endif
end do
c
c Check if remainder of the file is blank or comment lines
c
blank=' '//achar(9)
ispace=0
do while (ispace.eq.0)
read (11,1001,end=40) inline
c <a name=2><font color="0000FF">
ispace=verify(inline,blank)
c </font>
if (ispace.ne.0.and.inline(ispace:ispace).eq.'!') ispace=0
end do
c
c Write a message if the input file is too long
c
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 if (nwin.le.0) then
write(*,*) 'No Keyword information in the input deck'
inerr=inerr+1
endif
c
c Shut down on certain input errors
c
if(inerr.gt.0) then
write(*, *) inerr,' Fatal Errors during input from data file'
stop
endif
c
c Code to let the user determine the output for one variable
c
write(*,2000, advance='no')
2000 format (' Number of digits you want printed after the',
$ ' decimal',' for Temperatures: ')
read(*,*) ndigits
write(*,*)
ndigits=min(9,max(0,ndigits))
ispace=ndigits+6
write(tform,1002) ispace,ndigits
return
c
c Termination Messages for File problems
c
600 write(*, *)'Problem opening file: ', fname
stop
602 write(*, *) ' No Data in the Input File'
stop
c
c Some people like to put formats a the end of a routine in one
c organized location. I tend to group most with the associated
c I/O (read, write, print) statements, when they add to the
c immediate understanding of the code. I put formats with little
c important information, or that are used by several I/O statement
c at the end of the routine
c
1001 format (a)
1002 format ('f',i2,'.',i1)
end
c
c
c
subroutine leftjust(string)
implicit none
character string*(*), tab*1, ignore*2
integer lstring,istart
c
c John Mahaffy 3/8/96
c
c
c Its a good idea not to depend on the beginning of a user
c response landing in the first character of the string
c being read. Infrequently people hit a space before letters.
c With Unix it is possible to obtain normal keyboard input from
c a file (e.g. "a.out < keyin" takes input from the file "keyin")
c People frequently add spaces or tabs to begin lines in such
c files to Highlight certain items.
c
c This subroutine removes leading blanks and tabs. If only blanks
c were expected, the contents could be replaced by applying the
c Fortran 90 character function "adjustl"
c
c string = adjustl(string)
c
lstring=len(string)
c
c A "Tab" is character 9 in the ASCII character set. Use of the
c "achar" function lets me ignore the peculiarities of machine
c specific character sets. (Most are ASCII now, but IBM holds out
c with the EBCDIC set on its mainframes, and I'm suspect there are
c other's with peculiar sets.)
c<a name="achar"><font color="FF0000">
tab=achar(9)
c</font></a>
ignore=' '//tab
c
c Find the first character that is not in "ignore" (not tab or blank)
c
istart= verify(string,ignore)
if(istart.ne.0) string=string(istart:lstring)
return
end
c
c
c
subroutine upper(string)
c
c Convert lower case to upper case.
c Use of the new "achar" and "aichar" is not particularly
c crucial here, so I'll leave the old ichar and char.
c
c John Mahaffy 3/8/96
c
character string*(*)
lc=len(string)
icdiff=ichar('A')-ichar('a')
do i=1,lc
if(string(i:i).lt.'a'.or.string(i:i).gt.'z') cycle
c
c shift lower case to upper case
c
string(i:i)=char(ichar(string(i:i))+icdiff)
end do
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 iwords(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 iwords - 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,iwords,ierr)
if (ierr.eq.1) then
write(*, *) 'Word length exceeded in line 1'
else if (ierr.eq.2) then
write (*, *) 'Nothing to parse in Line 1 ( non-fatal)'
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
c
c Blank out the previous contents of "oline"
c
oline=' '
c
c Put only the non-blank portions of each word in to the line
c
do i=1,nwords
c <a name=3><font color="FF0000">
iwords(i) = len_trim(words(i))
c </font>
ilow=min(ihigh+1,loline)
ihigh=min(ihigh+iwords(i)+1 ,loline)
oline(ilow:ihigh)=words(i)(1:iwords(i))//' '
end do
c
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:iwords(i)),i=1,nwords)
return
2000 format (a)
2001 format ('(',i3,'(a,'' ''))')
end
c
c
c
subroutine parsl (line,sym,nfnd,nsym,isym,ierr)
implicit none
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 Fortran 90 Functions make this job much simpler
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
integer isym(*)
integer istart, iend, ierr, lline, nsym, lsym, nfnd, iexp, i
character line*(*),sym(*)*(*)
character (len=4) :: sep=' ,= '
c
c Its easy now. Let's add the Tab as a separator.
c
sep(4:4)=achar(9)
lsym=len(sym(1))
lline=len(line)
iexp = index(line,'!')
if(iexp.gt.0) lline=iexp-1
nsym=0
ierr=0
iend=0
c
c Loop to find all words (symbols) in the line
c
do while (nsym.le.nfnd.and.iend.lt.lline)
c
c Note how I must offset the results of verify. Verify
c returns a value of 1 if a character not found in "sep"
c is located in character position iend+1 of "line".
c
istart = verify (line((iend+1):lline),sep)+iend
c<a name="exit"><font color="FF0000">
if(istart.eq.iend) exit
c</font></a>
nsym=nsym+1
isym(nsym)=istart
c <a name=4><font color="FF0000">
iend = scan(line((istart+1):lline),sep)+istart-1
c </font>
if (iend.lt.istart) iend=lline
if (iend-istart+1.le.lsym) then
sym(nsym)=line(istart:iend)
cycle
else
ierr=1
write(*,2002) lsym
2002 format(' This word has more than',i3,' characters')
call poinat(line,9,(istart+lsym/2))
sym(nsym)= line(istart:(istart+lsym-1))
endif
end do
sym((nsym+1):nfnd)=' '
if ( nsym.eq.0) ierr=2
return
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
c <a name="case"><font color="FF0000">
select case (keyword(i))
c </a></font>
case ('T','TEMP','TEMPERATURE')
t=value(i)
write(*,form1) t
case ('P','PRES', 'PRESSURE')
p=value(i)
write(*,2001) p
case default
write(*,2002) i
write(*,'(a)') keyword(i)
write(*,*)
c<a name="es"><font color="FF0000">
end select
c</a></font>
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>
Copyright ©2017 - STI - Todos os direitos reservados