| Class | dc_units |
| In: |
src/dc_units.f90
|
| result : | logical |
| u1 : | type(units), intent(in) |
| u2 : | type(units), intent(in) |
logical function add_okay(u1, u2) result(result)
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.0d0))) then
result = .true.
else
result = .false.
endif
call deallocate(x)
end function
| u : | type(units), intent(inout) |
subroutine dcunitsclear(u)
type(units), intent(inout):: u
nullify(u%name)
nullify(u%power)
u%factor = 1.0_DP
u%offset = ""
u%nelems = 0
end subroutine
| result : | type(units) |
| u1 : | type(units), intent(in) |
| u2 : | type(units), intent(in) |
type(units) function dcUnitsAdd(u1, u2) result(result)
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.0d0))) 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)
end function
| result : | type(units) |
| u1 : | type(units), intent(in) |
| u2 : | type(units), intent(in) |
type(units) function dcUnitsDiv(u1, u2) result(result)
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)
end function
| result : | type(units) |
| u1 : | type(units), intent(in) |
| u2 : | type(units), intent(in) |
type(units) function dcUnitsMul(u1, u2) result(result)
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)
end function
| u : | type(units), intent(out) |
| cunits : | character(STRING), intent(in) |
subroutine dcunitsbuild(u, cunits)
type(units), intent(out):: u
character(STRING), intent(in):: cunits
! 構築中の情報、乗算対象の列として保持する。
! これは shift オペレータ付き単位を乗算できないことを示す。
type(elem_units), target:: ustack(100)
integer:: ui = 1
! 構文単位が占める乗算対象の stack における最初の添字
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 *, "DCUnitsBuild: syntax error, operator(**) ignored"
end subroutine
| string : | character(*), intent(out) |
| u : | type(units), intent(in) |
subroutine dcunitstostring(string, u)
character(*), intent(out):: string
type(units), intent(in):: u
integer:: i, ip, npower
character(TOKEN):: buffer
character:: mul = '.'
real(DP), parameter:: allowed = epsilon(1.0d0) * 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
end subroutine
| u : | type(units), intent(inout) |
subroutine dcunitsdeallocate(u)
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
end subroutine
subroutine error
print *, "DCUnitsBuild: unexpected token <", trim(cvalue), "> ignored"
end subroutine
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
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
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
| u : | type(units), intent(inout) |
| name(u%nelems) : | character(TOKEN), intent(in) |
| power(u%nelems) : | real(DP), intent(in) |
subroutine units_simplify(u, name, power)
type(units), intent(inout):: u
character(TOKEN), 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
end subroutine