c ccharvar.f c c
      
	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 
      inquire (file=fname,exist=fexist)
c 
      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 
         read(string(2),'(e16.5)',iostat=ioerr) value(nwin)
c 
         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
      ndigits=min(9,max(0,ndigits))
c
      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
      lc=len(string)
c
      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
         ilow=min(ihigh+1,loline)
         ihigh=min(ihigh+lwords(i)+1 ,loline)
c
  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 
c c c