dcunits_com.f90

Go to the documentation of this file.

!== dcunits_com.f90 - 単位系処理用の下位モジュール
!
! Authors::   Eizi TOYODA, Yasuhiro MORIKAWA
! Version::   $Id: dcunits_com.f90,v 1.2 2009-03-23 22:01:42 morikawa Exp $
! Tag Name::  $Name:  $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!
! This file provides dcunits_com
!
 
module dcunits_com !:nodoc:
  !
  !== Overview
  !
  ! dc_units モジュールで用いる下位の定数およびサブルーチンを提供します。
  !
  ! common private data for dc_units module
  !
 
  use dc_types, only: dp, string
  implicit none
  private
  public:: s_eof, s_shift, s_text, s_multiply, s_divide, s_exponent
  public:: s_openpar, s_closepar, s_real, s_integer
  public:: dcunitssetline, dcunitsgettoken
 
  ! scannter symbols
  integer, parameter:: s_eof = -128
  integer, parameter:: s_shift = 300
  integer, parameter:: s_text = 301
  integer, parameter:: s_multiply = 302
  integer, parameter:: s_divide = 303
  integer, parameter:: s_exponent = 304
  integer, parameter:: s_openpar = 305
  integer, parameter:: s_closepar = 306
  integer, parameter:: s_real = 307
  integer, parameter:: s_integer = 308
 
  ! scanner buffer
  character(STRING), private, save:: thisline = ""
  integer, private, save:: i = 1
 
contains
 
  subroutine dcunitssetline(line)
    implicit none
    character(*), intent(in):: line
    thisline = line
    i = 1
  end subroutine dcunitssetline
 
  subroutine dcunitsgettoken(tokentype, ivalue, dvalue, cvalue)
    use dc_regex, only: match
    implicit none
    integer, intent(out):: tokentype
    integer, intent(out):: ivalue(5)
    real(dp), intent(out):: dvalue
    character(*), intent(out):: cvalue
    integer:: iend, istr, ilen, ios
    ivalue = 0
    dvalue = 0.0_dp
    cvalue = ""
    iend = len_trim(thisline)
    do
      if (i > iend) exit
      ! '#' 文字が現われれば EOF シンボルを返す
      call match("^##", thisline(i:), istr, ilen)
      if (istr > 0) then
        i = iend + 1
        tokentype = s_eof
        return
      endif
      ! 空白を無視
      call match("^#s+", thisline(i:), istr, ilen)
      if (istr > 0) then
        i = i + ilen
        if (i > iend) exit
      endif
      ! シフト演算子チェック
      call match("^@", thisline(i:), istr, ilen)
      if (istr <= 0) call match("^from", thisline(i:), istr, ilen)
      if (istr <= 0) call match("^at", thisline(i:), istr, ilen)
      if (istr > 0) then
        i = i + ilen
        tokentype = s_shift
        cvalue = thisline(i: i+ilen-1)
        return
      endif
      ! 名前チェック
      call match("^#a#w*#a", thisline(i:), istr, ilen)
      if (istr <= 0) call match("^[#a'""]", thisline(i:), istr, ilen)
      if (istr > 0) then
        tokentype = s_text
        cvalue = thisline(i: i+ilen-1)
        i = i + ilen
        return
      endif
      ! '*' の前に '**' を認知せねば。
      call match("^#^", thisline(i:), istr, ilen)
      if (istr <= 0) call match("^#*#*", thisline(i:), istr, ilen)
      if (istr > 0) then
        tokentype = s_exponent
        cvalue = thisline(i: i+ilen-1)
        i = i + ilen
        return
      endif
      ! 実数にならない小数点は S_MULTIPLY
      call match("^#.[^#d]", thisline(i:), istr, ilen)
      if (istr <= 0) call match("^#*", thisline(i:), istr, ilen)
      if (istr > 0) then
        tokentype = s_multiply
        cvalue = thisline(i: i+ilen-1)
        i = i + 1
        return
      endif
      ! 実数チェック. 小数点は語頭にあれば必ず数字が伴うので安心せよ
      call match("^[-+]?#d*#.#d*[EeDd][-+]?#d+", thisline(i:), istr, ilen)
      if (istr <= 0) call match("^[-+]?#d*#.#d*", thisline(i:), istr, ilen)
      if (istr > 0) then
        read(thisline(i: i+ilen-1), fmt=*, &
          & iostat=ios) dvalue
        if (ios /= 0) dvalue = huge(dvalue)
        cvalue = thisline(i: i+ilen-1)
        tokentype = s_real
        i = i + ilen
        return
      endif
      ! 整数チェック
      call match("^[-+]?#d+", thisline(i:), istr, ilen)
      if (istr > 0) then
        read(thisline(i: i+ilen-1), fmt=*, &
          & iostat=ios) ivalue(1)
        if (ios /= 0) ivalue(1) = huge(1)
        cvalue = thisline(i: i+ilen-1)
        tokentype = s_integer
        i = i + ilen
        return
      endif
      ! ほかの１字トークンチェック
      if (thisline(i:i) == '/') then
        tokentype = s_divide
        cvalue = thisline(i:i)
        i = i + 1
        return
      endif
      if (thisline(i:i) == '(') then
        tokentype = s_openpar
        cvalue = thisline(i:i)
        i = i + 1
        return
      endif
      if (thisline(i:i) == ')') then
        tokentype = s_closepar
        cvalue = thisline(i:i)
        i = i + 1
        return
      endif
      ! だめだこりゃ。はい次いってみよう
      tokentype = ichar(thisline(i:i))
      cvalue = thisline(i:i)
      i = i + 1
      return
    enddo
    i = iend + 1
    tokentype = s_eof
    cvalue = ""
  end subroutine dcunitsgettoken
 
end module dcunits_com