c ccharvar90.f c c

      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 
      open (11,file=fname,status='old',err=600)
c 
      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
            if (nstring.le.0) cycle
c
            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   
c        string(2)=adjustr(string(2))
c        
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        
         ispace=verify(inline,blank)
c         
         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
      tab=achar(9)
c
      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     
         iwords(i) =  len_trim(words(i))
c    
         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
         if(istart.eq.iend) exit
c
         nsym=nsym+1
         isym(nsym)=istart
c 
         iend = scan(line((istart+1):lline),sep)+istart-1
c 
         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 
         select case (keyword(i))
c 
            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
         end select
c
  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