dc_units Module Reference

Data Types
interface	assignment(=)
interface	clear
interface	deallocate
interface	operator(*)
interface	operator(+)
interface	operator(/)
type	units

Functions/Subroutines
subroutine, private	units_simplify (u, name, power)
type(units) function	dcunitsmul (u1, u2)
type(units) function	dcunitsdiv (u1, u2)
type(units) function	dcunitsadd (u1, u2)
logical function, public	add_okay (u1, u2)
subroutine	dcunitsclear (u)
subroutine	dcunitsdeallocate (u)
subroutine	dcunitstostring (string, u)
subroutine	dcunitsbuild (u, cunits)

Function/Subroutine Documentation

add_okay()

logical function, public dc_units::add_okay	(	type(units), intent(in)	u1,
		type(units), intent(in)	u2
	)

Definition at line 175 of file dc_units.f90.

Referenced by getmatch().

    type(units), intent(in):: u1, u2
    type(units):: x
    character(STRING):: debug
    call clear(x)
    x = u1 / u2
    debug = u1
    debug = u2
    debug = x
    if (x%nelems == 0) then
      result = .true.
    else if (all(abs(x%power(1:x%nelems)) < tiny(0.0_dp))) then
      result = .true.
    else
      result = .false.
    endif
    call deallocate(x)

Here is the caller graph for this function:

dcunitsadd()

type(units) function dc_units::dcunitsadd ( type(units), intent(in)  u1, type(units), intent(in)  u2  )

private

Definition at line 152 of file dc_units.f90.

    type(units), intent(in):: u1, u2
    type(units):: x
    result%offset = u1%offset
    result%nelems = u1%nelems
    result%factor = u1%factor + u2%factor
    x = u1 / u2
    if (x%nelems == 0) then
      nullify(result%name, result%power)   
      return
    endif
    if (all(abs(x%power(1:result%nelems)) < tiny(0.0_dp))) then
      allocate(result%name(result%nelems), result%power(result%nelems))
      result%name = u1%name
      result%power = u1%power
      return
    endif
    result%factor = 0.0
    result%nelems = -1
    result%offset = "MISMATCH"
    nullify(result%name, result%power)   

dcunitsbuild()

subroutine dc_units::dcunitsbuild ( type(units), intent(out)  u, character(*), intent(in)  cunits  )

private

Definition at line 260 of file dc_units.f90.

References cancel_exp(), dcunits_com::dcunitsgettoken(), dcunits_com::dcunitssetline(), error(), factor_next(), power_next(), pstack_clear(), pstack_pop(), pstack_push(), dcunits_com::s_closepar, dcunits_com::s_divide, dcunits_com::s_eof, dcunits_com::s_exponent, dcunits_com::s_integer, dcunits_com::s_multiply, dcunits_com::s_openpar, dcunits_com::s_real, dcunits_com::s_shift, dcunits_com::s_text, units_finalize(), units_simplify(), ustack_clear(), and ustack_grow().

    !
    ! 文字型変数から UNITS 型変数を生成します (constructor)。
    !
    use dcunits_com
    type(units), intent(out):: u
    character(*), intent(in):: cunits

    ! 構築中の情報、乗算対象の列として保持する。
    ! これは shift オペレータ付き単位を乗算できないことを示す。
    type elem_units
      character(TOKEN):: name
      real(DP):: power, factor
    end type elem_units
    type(elem_units), target:: ustack(100)
    integer:: ui = 1

    ! 構文単位が占める乗算対象の stack における最初の添字
    type paren_t
      real(DP):: factor
      integer:: factor_exp
      logical:: factor_inv
      integer:: power_exp
      integer:: paren_exp
    end type paren_t
    type(paren_t):: pstack(50)
    integer:: pi = 1

    ! パーサの状態遷移
    integer, parameter:: y_init = 1, y_number = 2, y_name = 3, &
      & y_nx = 4, y_ni = 5, y_mul = 6, y_shift = 7
    integer:: yparse_status = y_init

    ! 字句
    integer:: ltype
    integer:: ivalue(5)
    real(DP):: dvalue
    character(TOKEN):: cvalue
    ! その他
    integer:: i
        
    ! --- 実行部 ---
    ! 初期化
    if (associated(u%name)) deallocate(u%name)
    if (associated(u%power)) deallocate(u%power)
    u%nelems = 0
    u%offset = ""
    u%factor = 1.0_dp
    if (cunits == "") return
    call dcunitssetline(cunits)
    call ustack_clear
    call pstack_clear
    yparse_status = y_init

    do
      call dcunitsgettoken(ltype, ivalue, dvalue, cvalue)
      select case(ltype)
      case (s_integer)
        select case(yparse_status)
        case (y_init, y_mul)
          pstack(pi)%factor = pstack(pi)%factor * ivalue(1)
          yparse_status = y_number
        case (y_name, y_nx)
          i = pstack(pi)%power_exp
          ustack(i:ui)%power = ustack(i:ui)%power * ivalue(1) 
          call power_next
          yparse_status = y_ni
        case (y_shift)
          u%offset = cvalue
        case default
          call error
        end select
      case (s_real)
        select case(yparse_status)
        case (y_init, y_mul)
          pstack(pi)%factor = pstack(pi)%factor * dvalue
          yparse_status = y_number
        case (y_name, y_nx)
          i = pstack(pi)%power_exp
          ustack(i:ui)%power = ustack(i:ui)%power * dvalue
          call power_next
          yparse_status = y_ni
        case (y_shift)
          u%offset = cvalue
        case default
          call error
        end select
      case (s_text)
        select case(yparse_status)
        case (y_init, y_number, y_mul)
          ustack(ui)%name = cvalue
          yparse_status = y_name
        case (y_name, y_ni)
          call ustack_grow
          call power_next
          ustack(ui)%name = cvalue
          yparse_status = y_name
        case (y_shift)
          u%offset = cvalue
        case default
          call error
        end select
      case (s_exponent)
        select case(yparse_status)
        case (y_name)
          yparse_status = y_nx
        case default
          call error
        end select
      case (s_multiply)
        select case(yparse_status)
        case (y_number, y_name)
          call factor_next
          yparse_status = y_mul
        case default
          call error
        end select
      case (s_divide)
        select case(yparse_status)
        case (y_number, y_name)
          call factor_next
          pstack(pi)%factor_inv = .true.
          yparse_status = y_mul
        case default
          call error
        end select
      case (s_shift)
        if (yparse_status == y_nx) call cancel_exp
        call units_finalize
        yparse_status = y_shift
      case (s_openpar)
        if (yparse_status == y_nx) call cancel_exp
        call pstack_push
      case (s_closepar)
        call units_finalize
        call pstack_pop
      case (s_eof)
        exit
      case default
        call error
      end select
    enddo
    if (yparse_status == y_nx) call cancel_exp
    call units_finalize

    u%nelems = ui
    u%factor = product(ustack(1:ui)%factor)
    call units_simplify(u, ustack(1:ui)%name, ustack(1:ui)%power)

  contains

    subroutine cancel_exp
      print *, operator"DCUnitsBuild: syntax error, (**) ignored"
    end subroutine cancel_exp

    subroutine error
      print *, "DCUnitsBuild: unexpected token <", &
        & trim(cvalue), "> ignored"
    end subroutine error

    subroutine power_next
      ! power_exp の終了処理
      call ustack_grow
      pstack(pi)%power_exp = ui
    end subroutine power_next

    subroutine factor_next
      ! factor_exp の終了処理
      real(DP):: factor
      i = pstack(pi)%factor_exp
      factor = product(ustack(i:ui)%factor) * pstack(pi)%factor
      if (pstack(pi)%factor_inv) then
        ustack(i:ui)%power = -ustack(i:ui)%power
        factor = 1.0_dp / factor
      endif
      ustack(i)%factor = factor
      ustack(i+1:ui)%factor = 1.0_dp
      call power_next
      pstack(pi)%factor = 1.0_dp
      pstack(pi)%factor_exp = ui
    end subroutine factor_next

    subroutine units_finalize
      call factor_next
    end subroutine units_finalize

    subroutine ustack_clear
      ui = 0
      call ustack_grow
    end subroutine ustack_clear

    subroutine ustack_grow
      if (ui >= size(ustack)) stop 'DCUnitsBuild: too many elements'
      ui = ui + 1
      ustack(ui)%name = ""
      ustack(ui)%factor = 1.0_dp
      ustack(ui)%power = 1.0_dp
    end subroutine ustack_grow

    subroutine pstack_clear
      pi = 0
      call pstack_push
    end subroutine pstack_clear

    subroutine pstack_push
      if (pi >= size(pstack)) stop 'DCUnitsBuild: too many parens'
      pi = pi + 1
      call ustack_grow
      pstack(pi)%factor_exp = ui
      pstack(pi)%factor = 1.0_dp
      pstack(pi)%factor_inv = .false.
      pstack(pi)%power_exp = ui
      pstack(pi)%paren_exp = ui
    end subroutine pstack_push

    subroutine pstack_pop
      ! factor_exp の終了処理
      call power_next
      pi = pi - 1
    end subroutine pstack_pop

Here is the call graph for this function:

dcunitsclear()

subroutine dc_units::dcunitsclear ( type(units), intent(inout)  u )

private

Definition at line 194 of file dc_units.f90.

    type(units), intent(inout):: u
    nullify(u%name)
    nullify(u%power)
    u%factor = 1.0_dp
    u%offset = ""
    u%nelems = 0

dcunitsdeallocate()

subroutine dc_units::dcunitsdeallocate ( type(units), intent(inout)  u )

private

Definition at line 203 of file dc_units.f90.

    type(units), intent(inout):: u
    if (associated(u%name)) deallocate(u%name)
    if (associated(u%power)) deallocate(u%power)
    u%factor = 1.0_dp
    u%offset = ""
    u%nelems = 0

dcunitsdiv()

type(units) function dc_units::dcunitsdiv ( type(units), intent(in)  u1, type(units), intent(in)  u2  )

private

Definition at line 118 of file dc_units.f90.

References units_simplify().

    type(units), intent(in):: u1, u2
    integer:: n, n1
    character(TOKEN), allocatable:: name(:)
    real(DP), allocatable:: power(:)
    if (abs(u2%factor) < tiny(u2%factor)) then
      result%factor = sign(u1%factor, 1.0_dp) * &
        & sign(u2%factor, 1.0_dp) * &
        & huge(1.0_dp)
    else
      result%factor = u1%factor / u2%factor
    endif
    result%nelems = u1%nelems + u2%nelems
    result%offset = ""
    n = result%nelems
    if (n == 0) then
      nullify(result%name, result%power)
      return
    endif
    allocate(name(n), power(n))
    n1 = u1%nelems
    if (n1 >= 1) then
      name(1:n1) = u1%name(1:n1)
      power(1:n1) = u1%power(1:n1)
    endif
    n1 = n1 + 1
    if (n >= n1) then
      name(n1:n) = u2%name(1:u2%nelems)
      power(n1:n) = -u2%power(1:u2%nelems)
    endif
    call units_simplify(result, name, power)
    deallocate(name, power)

Here is the call graph for this function:

dcunitsmul()

type(units) function dc_units::dcunitsmul ( type(units), intent(in)  u1, type(units), intent(in)  u2  )

private

Definition at line 98 of file dc_units.f90.

References units_simplify().

    type(units), intent(in):: u1, u2
    integer:: n
    character(TOKEN), allocatable:: name(:)
    real(DP), allocatable:: power(:)
    result%factor = u1%factor * u2%factor
    result%nelems = u1%nelems + u2%nelems
    result%offset = ""
    n = result%nelems
    if (n == 0) then
      nullify(result%name, result%power)
      return
    endif
    allocate(name(n), power(n))
    name = (/u1%name, u2%name/)
    power = (/u1%power, u2%power/)
    call units_simplify(result, name, power)
    deallocate(name, power)

Here is the call graph for this function:

dcunitstostring()

subroutine dc_units::dcunitstostring ( character(*), intent(out)  string, type(units), intent(in)  u  )

private

Definition at line 212 of file dc_units.f90.

    !
    ! UNITS 型変数から文字型変数を生成します。
    !
    character(*), intent(out):: string
    type(units), intent(in):: u
    integer:: i, ip, npower
    character(TOKEN):: buffer
    character:: mul = '.'
    real(DP), parameter:: allowed = epsilon(1.0_dp) * 16.0

    if (u%nelems < 0) then
      string = 'error from ' // u%offset
      return 
    endif

    write(buffer, "(1pg20.12)") u%factor
    string = buffer
    if (u%nelems < 1) return

    if (abs(u%factor - 1.0) < allowed) then
      string = ""
    else if (abs(u%factor + 1.0) < allowed) then
      string = "-"
    endif

    ip = len_trim(string) + 1
    do, i = 1, u%nelems
      npower = nint(u%power(i))
      if (abs(1.0 - u%power(i)) < allowed) then
        buffer = " "
      else if (abs(npower - u%power(i)) < allowed) then
        write(buffer, "(i10)") npower
        buffer = adjustl(buffer)
      else
        write(buffer, "(1pg10.3)") u%power(i)
        buffer = adjustl(buffer)
      endif
      if (buffer == '0') cycle
      string = trim(string) // mul // trim(u%name(i)) // trim(buffer)
    enddo
    if (ip <= len(string)) string(ip:ip) = ' '
    if (string(1:1) == " ") string = adjustl(string)
    if (u%offset /= "") then
      string = trim(string) // '@' // trim(u%offset)
    endif

units_simplify()

subroutine, private dc_units::units_simplify ( type(units), intent(inout)  u, character(*), dimension(u%nelems), intent(in)  name, real(dp), dimension(u%nelems), intent(in)  power  )

private

Definition at line 63 of file dc_units.f90.

Referenced by dcunitsbuild(), dcunitsdiv(), and dcunitsmul().

    type(units), intent(inout):: u
    character(*), intent(in):: name(u%nelems)
    real(DP), intent(in):: power(u%nelems)
    integer:: i, n, j, onazi
    integer:: table(u%nelems)

    if (u%nelems < 1) return
    table(:) = 0
    n = 0
    do, i = 1, u%nelems
      if (name(i) == '') cycle
      onazi = 0
      do, j = 1, i - 1
        if (name(j) == name(i)) then
          onazi = j
        endif
      enddo
      if (onazi > 0) then
        table(i) = table(onazi)
      else
        n = n + 1
        table(i) = n
      endif
    enddo
    allocate(u%name(n), u%power(n))
    u%power = 0.0_dp
    do, i = 1, u%nelems
      if (table(i) == 0) cycle
      u%name(table(i)) = name(i)
      u%power(table(i)) = u%power(table(i)) + power(i)
    enddo
    u%nelems = n

Here is the caller graph for this function: