760 lines
22 KiB
Fortran
760 lines
22 KiB
Fortran
! Implementation code for stack
|
|
submodule (rpn_stack) stack_sm
|
|
implicit none
|
|
|
|
contains
|
|
|
|
module subroutine set_legend_stackt(stk, legend)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
character(len=2), intent(in) :: legend(:)
|
|
stk%legend = legend
|
|
end subroutine set_legend_stackt
|
|
|
|
module function get_size_stackt(stk) result(r)
|
|
class(stack_t(*)), intent(in) :: stk
|
|
integer :: r
|
|
r = stk%high_water
|
|
end function get_size_stackt
|
|
|
|
module subroutine print_stackt(stk, ve_mode)
|
|
class(stack_t(*)), intent(in) :: stk
|
|
logical, intent(in) :: ve_mode
|
|
integer :: i, j
|
|
if (ve_mode) then
|
|
do i=stk%high_water,1,-1
|
|
write(6,fmt='(a)',advance='no') stk%legend(i)//' '
|
|
write(6,'(dt)') stk%sdata(i)
|
|
end do
|
|
else
|
|
write(6,fmt='(dt)') stk%sdata(1)
|
|
end if
|
|
end subroutine print_stackt
|
|
|
|
module subroutine push_stackt(stk, z)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
type(rpn_t) :: z
|
|
integer :: i
|
|
do i=stk%ssize,2,-1
|
|
stk%sdata(i) = stk%sdata(i-1)
|
|
end do
|
|
stk%sdata(1) = z
|
|
if (stk%high_water < stk%ssize) &
|
|
stk%high_water = stk%high_water + 1
|
|
end subroutine push_stackt
|
|
|
|
module subroutine push_r_stackt(stk, x)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
real(8) :: x
|
|
type(rpn_t) :: z
|
|
z = rpn_t(cmplx(x,0.0d0))
|
|
call stk%push_stackt(z)
|
|
end subroutine push_r_stackt
|
|
|
|
module subroutine push_all_stackt(stk, z, is_cart)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
complex(8), intent(in) :: z
|
|
logical, intent(in), optional :: is_cart
|
|
integer :: i
|
|
do i=stk%ssize,2,-1
|
|
stk%sdata(i) = stk%sdata(i-1)
|
|
end do
|
|
if (present(is_cart)) then
|
|
call stk%set(rpn_t(z,is_cart))
|
|
else
|
|
call stk%set(rpn_t(z))
|
|
end if
|
|
if (stk%high_water < stk%ssize) &
|
|
stk%high_water = stk%high_water + 1
|
|
end subroutine push_all_stackt
|
|
|
|
module subroutine set_stackt(stk, z, idx)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
type(rpn_t), intent(in) :: z
|
|
integer, optional, intent(in) :: idx
|
|
if (present(idx)) then
|
|
stk%sdata(idx) = z
|
|
else
|
|
stk%sdata(1) = z
|
|
end if
|
|
end subroutine set_stackt
|
|
|
|
module function peek_stackt(stk, idx) result(r)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
integer, intent(in) :: idx
|
|
type(rpn_t) :: r
|
|
if (idx >= 1 .and. idx <= stk%ssize) then
|
|
r = stk%sdata(idx)
|
|
else
|
|
write(*,'(a,i0,a)') '***Invalid index (',idx,')'
|
|
r = rpn_t()
|
|
end if
|
|
end function peek_stackt
|
|
|
|
module function pop_stackt(stk) result(r)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
type(rpn_t) :: r
|
|
integer :: i
|
|
r = stk%sdata(1)
|
|
do i=1,stk%ssize-1
|
|
stk%sdata(i) = stk%sdata(i+1)
|
|
end do
|
|
stk%sdata(stk%ssize) = rpn_t()
|
|
if (stk%high_water > 0) &
|
|
stk%high_water = stk%high_water - 1
|
|
end function pop_stackt
|
|
|
|
module subroutine clear_stackt(stk)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
integer :: i
|
|
do i=1,stk%ssize
|
|
stk%sdata(i) = rpn_t()
|
|
end do
|
|
stk%high_water = 0
|
|
end subroutine clear_stackt
|
|
|
|
module subroutine swap_stackt(stk)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
integer :: i
|
|
type(rpn_t) :: z
|
|
z = stk%sdata(1)
|
|
stk%sdata(1) = stk%sdata(2)
|
|
stk%sdata(2) = z
|
|
end subroutine swap_stackt
|
|
|
|
module subroutine rotate_up_stackt(stk)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
type(rpn_t) :: z
|
|
z = stk%pop()
|
|
stk%high_water = stk%high_water + 1
|
|
call stk%set(z,stk%high_water)
|
|
end subroutine rotate_up_stackt
|
|
|
|
module subroutine rotate_down_stackt(stk)
|
|
class(stack_t(*)), intent(inout) :: stk
|
|
type(rpn_t) :: z
|
|
z = stk%peek(stk%high_water)
|
|
stk%high_water = stk%high_water - 1
|
|
call stk%push(z)
|
|
end subroutine rotate_down_stackt
|
|
|
|
end submodule stack_sm
|
|
|
|
! Implementation code for rpn_t
|
|
submodule (rpn_stack) rpn_sm
|
|
contains
|
|
|
|
module subroutine write_rpns(se, unit, iotype, v_list, iostat, iomsg)
|
|
class(rpn_t), intent(in) :: se
|
|
integer, intent(in) :: unit
|
|
character(*), intent(in) :: iotype
|
|
integer, intent(in) :: v_list(:)
|
|
integer, intent(out) :: iostat
|
|
character(*), intent(inout) :: iomsg
|
|
complex(8) :: z
|
|
character(len=:), allocatable :: str_re, str_im
|
|
iostat = 0
|
|
iomsg = ""
|
|
z = se%zdata
|
|
if (complex_mode) then
|
|
call to_string(z%re,str_re)
|
|
call to_string(z%im,str_im)
|
|
if (se%is_cartesian()) then
|
|
write(6,'(a)') '('//str_re//','//str_im//')'
|
|
else
|
|
write(6,'(a)') '('//str_re//','//str_im//') p'
|
|
end if
|
|
else
|
|
call to_string(z%re,str_re)
|
|
write(6,'(a)') str_re
|
|
end if
|
|
|
|
end subroutine write_rpns
|
|
|
|
! Convert real to string inserting a leading 0 if necessary
|
|
module subroutine to_string(x, str)
|
|
real(8), intent(in) :: x
|
|
character(len=:), allocatable, intent(out) :: str
|
|
character(len=32) :: s
|
|
s = ' '
|
|
if (f_small == 'i0') then
|
|
write(s,fmt='('//f_small//')') nint(x)
|
|
else
|
|
if (x == 0 .or. (abs(x) < 1.0d7 .and. abs(x) > 1.0d-7)) then
|
|
write(s(2:),fmt='('//f_small//')') x
|
|
else
|
|
write(s(2:),fmt='('//f_large//')') x
|
|
end if
|
|
if (s(2:3) == '-.') then
|
|
s(1:3) = '-0.'
|
|
else if (s(2:2) == '.') then
|
|
s(1:2) = '0.'
|
|
end if
|
|
end if
|
|
str = trim(adjustl(s))
|
|
end subroutine to_string
|
|
|
|
module function is_integer_rpns(this) result(r)
|
|
class(rpn_t), intent(in) :: this
|
|
logical :: r
|
|
real(8) :: x
|
|
x = this%zdata%re
|
|
r = (abs(nint(x)-x) < eps .and. abs(this%zdata%im) < eps)
|
|
end function is_integer_rpns
|
|
|
|
module function is_cartesian_rpns(this) result(r)
|
|
class(rpn_t), intent(in) :: this
|
|
logical :: r
|
|
r = this%is_cart
|
|
end function is_cartesian_rpns
|
|
|
|
module function is_real_rpns(this) result(r)
|
|
class(rpn_t), intent(in) :: this
|
|
logical :: r
|
|
r = this%zdata%im == 0
|
|
end function is_real_rpns
|
|
|
|
module function is_positive_real_rpns(this) result(r)
|
|
class(rpn_t), intent(in) :: this
|
|
logical :: r
|
|
r = this%zdata%im == 0 .and. this%zdata%re > 0
|
|
end function is_positive_real_rpns
|
|
|
|
module subroutine set_angle_unit_rpns(this, degrees)
|
|
class(rpn_t), intent(inout) :: this
|
|
logical, intent(in) :: degrees
|
|
if (.not. this%is_cart) then
|
|
this%zdata%im = this%zdata%im*merge(to_deg, to_rad, degrees)
|
|
end if
|
|
end subroutine set_angle_unit_rpns
|
|
|
|
module function get_value_rpns(this, is_cartesian) result(r)
|
|
class(rpn_t), intent(in) :: this
|
|
logical, optional, intent(out) :: is_cartesian
|
|
complex(8) :: r
|
|
r = this%zdata
|
|
if (present(is_cartesian)) then
|
|
is_cartesian = this%is_cart
|
|
end if
|
|
end function get_value_rpns
|
|
|
|
module subroutine set_value_rpns(this, z, is_cartesian)
|
|
class(rpn_t), intent(inout) :: this
|
|
complex(8), optional, intent(in) :: z
|
|
logical, optional, intent(in) :: is_cartesian
|
|
if (present(z)) then
|
|
this%zdata = z
|
|
end if
|
|
if (present(is_cartesian)) then
|
|
this%is_cart = is_cartesian
|
|
end if
|
|
end subroutine set_value_rpns
|
|
|
|
module subroutine set_to_rpns(this, z)
|
|
class(rpn_t), intent(inout) :: this
|
|
type(rpn_t), intent(in) :: z
|
|
this%zdata = z%zdata
|
|
this%is_cart = z%is_cart
|
|
end subroutine set_to_rpns
|
|
|
|
module function add_rpns(a, b) result(r)
|
|
class(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
type(rpn_t) :: s
|
|
logical :: is_cart
|
|
is_cart = a%is_cartesian() ! The output will be set to this
|
|
if (a%is_cartesian()) then
|
|
r = a
|
|
else
|
|
r = to_cartesian(a)
|
|
end if
|
|
if (b%is_cartesian()) then
|
|
r%zdata = r%zdata + b%zdata
|
|
else
|
|
s = to_cartesian(a)
|
|
r%zdata = r%zdata + s%zdata
|
|
end if
|
|
if (.not. is_cart) then
|
|
r = to_polar(r)
|
|
end if
|
|
end function add_rpns
|
|
|
|
module function subtract_rpns(a, b) result(r)
|
|
class(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
type(rpn_t) :: s
|
|
logical :: is_cart
|
|
is_cart = a%is_cartesian() ! The output will be set to this
|
|
if (a%is_cartesian()) then
|
|
r = a
|
|
else
|
|
r = to_cartesian(a)
|
|
end if
|
|
if (b%is_cartesian()) then
|
|
r%zdata = r%zdata - b%zdata
|
|
else
|
|
s = to_cartesian(a)
|
|
r%zdata = r%zdata - s%zdata
|
|
end if
|
|
if (.not. is_cart) then
|
|
r = to_polar(r)
|
|
end if
|
|
end function subtract_rpns
|
|
|
|
module function multiply_rpns(a, b) result(r)
|
|
class(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
type(rpn_t) :: s
|
|
logical :: is_cart
|
|
is_cart = a%is_cartesian() ! The output will be set to this
|
|
if (a%is_cartesian()) then
|
|
r = a
|
|
else
|
|
r = to_cartesian(a)
|
|
end if
|
|
if (b%is_cartesian()) then
|
|
r%zdata = r%zdata * b%zdata
|
|
else
|
|
s = to_cartesian(a)
|
|
r%zdata = r%zdata * s%zdata
|
|
end if
|
|
if (.not. is_cart) then
|
|
r = to_polar(r)
|
|
end if
|
|
end function multiply_rpns
|
|
|
|
module function divide_rpns(a, b) result(r)
|
|
class(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
type(rpn_t) :: s
|
|
logical :: is_cart
|
|
is_cart = a%is_cartesian() ! The output will be set to this
|
|
if (a%is_cartesian()) then
|
|
r = a
|
|
else
|
|
r = to_cartesian(a)
|
|
end if
|
|
if (b%is_cartesian()) then
|
|
r%zdata = r%zdata / b%zdata
|
|
else
|
|
s = to_cartesian(a)
|
|
r%zdata = r%zdata / s%zdata
|
|
end if
|
|
if (.not. is_cart) then
|
|
r = to_polar(r)
|
|
end if
|
|
end function divide_rpns
|
|
|
|
module function power_rpns(this, x) result(r)
|
|
class(rpn_t), intent(in) :: this
|
|
real(8), intent(in) :: x
|
|
type(rpn_t) :: r
|
|
type(rpn_t) :: z
|
|
logical :: is_cart
|
|
is_cart = this%is_cartesian()
|
|
if (.not. is_cart) then
|
|
z = to_cartesian(this)
|
|
else
|
|
z = this
|
|
end if
|
|
r%zdata = z%zdata**x
|
|
if (.not. is_cart) then
|
|
r = to_polar(r)
|
|
end if
|
|
end function power_rpns
|
|
|
|
module function to_cartesian_rpns(stk_z) result(r)
|
|
type(rpn_t), intent(in) :: stk_z
|
|
type(rpn_t) :: r
|
|
real(8) :: s
|
|
real(8) :: theta
|
|
if (.not. stk_z%is_cartesian()) then
|
|
s = stk_z%zdata%re
|
|
theta = stk_z%zdata%im * merge(to_rad,1.0d0,degrees_mode)
|
|
r%zdata%re = round(s * cos(theta))
|
|
r%zdata%im = round(s * sin(theta))
|
|
r%is_cart = .true.
|
|
else
|
|
r = stk_z
|
|
end if
|
|
end function to_cartesian_rpns
|
|
|
|
|
|
module function to_polar_rpns(stk_z) result(r)
|
|
type(rpn_t), intent(in) :: stk_z
|
|
type(rpn_t) :: r
|
|
real(8) :: theta
|
|
if (stk_z%is_cartesian()) then
|
|
call r%set_value(to_polar_internal(stk_z%get_value()),is_cartesian = .false.)
|
|
else
|
|
r = stk_z
|
|
end if
|
|
contains
|
|
complex(8) function to_polar_internal(z)
|
|
complex(8), intent(in) :: z
|
|
real(8) :: r
|
|
real(8) :: theta
|
|
r = sqrt(real(z * conjg(z),8))
|
|
theta = atan2(aimag(z), real(z))
|
|
to_polar_internal%re = r
|
|
to_polar_internal%im = theta * merge(1/to_rad,1.0d0,degrees_mode)
|
|
end function to_polar_internal
|
|
end function to_polar_rpns
|
|
|
|
module function add_fr(a,b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
r = a + b
|
|
end function add_fr
|
|
|
|
module function subtract_fr(a,b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
r = a - b
|
|
end function subtract_fr
|
|
|
|
module function multiply_fr(a,b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
r = a * b
|
|
end function multiply_fr
|
|
|
|
module function divide_fr(a,b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
r = a / b
|
|
end function divide_fr
|
|
|
|
module function percent_fr(a,b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
r = a * b / rpn_t(cmplx(100.0d0,0.0d0))
|
|
end function percent_fr
|
|
|
|
module function power_fr(a, b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
r = a ** real(b%zdata)
|
|
end function power_fr
|
|
|
|
module function power_2_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = a ** 2.0d0
|
|
end function power_2_fr
|
|
|
|
module function power_3_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = a ** 3.0d0
|
|
end function power_3_fr
|
|
|
|
module function sqrt_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
call r%set_value(sqrt(a%zdata))
|
|
end function sqrt_fr
|
|
|
|
module function cbrt_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
call r%set_value(a%zdata ** (1.0d0/3))
|
|
end function cbrt_fr
|
|
|
|
module function reciprocal_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(1.0d0)/a
|
|
end function reciprocal_fr
|
|
|
|
module function conj_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = a
|
|
r%zdata%im = -r%zdata%im
|
|
end function conj_fr
|
|
|
|
module function len_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
type(rpn_t) :: s
|
|
s = a * conj_fr(a)
|
|
r = rpn_t(cmplx(sqrt(real(s%zdata%re)),0.0d0,8))
|
|
end function len_fr
|
|
|
|
module function swap_real_imaginary_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
real(8) :: x
|
|
r = a
|
|
x = r%zdata%re
|
|
r%zdata%re = r%zdata%im
|
|
r%zdata%im = x
|
|
end function swap_real_imaginary_fr
|
|
|
|
module function chs_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(cmplx(-a%zdata%re,-a%zdata%im))
|
|
end function chs_fr
|
|
|
|
module function sine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(sin(a%zdata * merge(to_rad,1.0d0,degrees_mode)))
|
|
end function sine_fr
|
|
|
|
module function cosine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(cos(a%zdata%re * merge(to_rad,1.0d0,degrees_mode)))
|
|
end function cosine_fr
|
|
|
|
module function tangent_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(tan(a%zdata * merge(to_rad,1.0d0,degrees_mode)))
|
|
end function tangent_fr
|
|
|
|
module function hsine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(sinh(a%zdata))
|
|
end function hsine_fr
|
|
|
|
module function hcosine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(cosh(a%zdata))
|
|
end function hcosine_fr
|
|
|
|
module function htangent_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(tanh(a%zdata))
|
|
end function htangent_fr
|
|
|
|
module function asine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(asin(a%zdata) * merge(1/to_rad,1.0d0,degrees_mode))
|
|
end function asine_fr
|
|
|
|
module function acosine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(acos(a%zdata) * merge(1/to_rad,1.0d0,degrees_mode))
|
|
end function acosine_fr
|
|
|
|
module function atangent_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(atan(a%zdata) * merge(1/to_rad,1.0d0,degrees_mode))
|
|
end function atangent_fr
|
|
|
|
module function ahsine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(asinh(a%zdata))
|
|
end function ahsine_fr
|
|
|
|
module function ahcosine_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(acosh(a%zdata))
|
|
end function ahcosine_fr
|
|
|
|
module function ahtangent_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(atanh(a%zdata))
|
|
end function ahtangent_fr
|
|
|
|
module function exp_2_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(2**a%zdata)
|
|
end function exp_2_fr
|
|
|
|
module function exp_e_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(exp(a%zdata))
|
|
end function exp_e_fr
|
|
|
|
module function exp_10_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(10**a%zdata)
|
|
end function exp_10_fr
|
|
|
|
module function ln_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(log(a%zdata))
|
|
end function ln_fr
|
|
|
|
module function log2_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(log(a%zdata)/log(2.0d0))
|
|
end function log2_fr
|
|
|
|
module function lg_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(log(a%zdata)/log(10.0d0))
|
|
end function lg_fr
|
|
|
|
module function gamma_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
r = rpn_t(gamma(a%zdata%re))
|
|
end function gamma_fr
|
|
|
|
module function fact_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
if (a%zdata%re == 0) then
|
|
r = rpn_t(1)
|
|
else
|
|
r = rpn_t(a%zdata%re*gamma(a%zdata%re))
|
|
end if
|
|
end function fact_fr
|
|
|
|
module function ncr_fr(a, b) result(r)
|
|
type(rpn_t), intent(in) :: a, b
|
|
type(rpn_t) :: r
|
|
r = fact_fr(a)/(fact_fr(b)*fact_fr(a-b))
|
|
end function ncr_fr
|
|
|
|
module function npr_fr(a, b) result(r)
|
|
type(rpn_t), intent(in) :: a, b
|
|
type(rpn_t) :: r
|
|
r = fact_fr(a)/fact_fr(b)
|
|
end function npr_fr
|
|
|
|
module function root_fr(a, b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
real(8) :: bc
|
|
integer :: i
|
|
type(rpn_t) :: base
|
|
complex(8) :: z
|
|
logical :: a_is_cart
|
|
real(8) :: s, delta_theta, theta0, phi
|
|
real(8), parameter :: two_pi = 8*atan(1.0d0)
|
|
|
|
bc = real(b%get_value())
|
|
r = power_fr(a, rpn_t(1.0d0/bc))
|
|
! If b is an integer >= 2 calculate all roots
|
|
if (b%is_integer() .and. bc >= 2) then
|
|
nroots = nint(bc)
|
|
if (allocated(roots)) then
|
|
deallocate(roots)
|
|
end if
|
|
a_is_cart = a%is_cartesian()
|
|
base = to_polar_rpns(a)
|
|
z = base%get_value()
|
|
s = z%re ** (1.0d0/bc)
|
|
theta0 = merge(z%im*to_rad,z%im,degrees_mode)/nroots
|
|
delta_theta = two_pi/nroots
|
|
allocate(roots(nroots))
|
|
do i=1, nroots
|
|
phi = theta0 + (i-1)*delta_theta
|
|
if (a_is_cart) then
|
|
roots(i) = rpn_t(cmplx(round(s*cos(phi)),round(s*sin(phi))),a_is_cart)
|
|
else
|
|
if (degrees_mode) phi = phi*to_deg
|
|
roots(i) = rpn_t(cmplx(s,round(phi)),a_is_cart)
|
|
end if
|
|
end do
|
|
r = roots(1)
|
|
current_root = 1
|
|
else
|
|
r = a ** (1.0d0/bc)
|
|
end if
|
|
|
|
end function root_fr
|
|
|
|
module function next_root_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
if (nroots > 0) then
|
|
if (current_root == nroots) then
|
|
current_root = 1
|
|
else
|
|
current_root = current_root + 1
|
|
end if
|
|
r = roots(current_root)
|
|
else
|
|
r = a
|
|
end if
|
|
end function next_root_fr
|
|
|
|
module function previous_root_fr(a) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t) :: r
|
|
if (nroots > 0) then
|
|
if (current_root == 1) then
|
|
current_root = nroots
|
|
else
|
|
current_root = current_root - 1
|
|
end if
|
|
r = roots(current_root)
|
|
else
|
|
r = a
|
|
end if
|
|
end function previous_root_fr
|
|
|
|
module function atangent2_fr(a, b) result(r)
|
|
type(rpn_t), intent(in) :: a
|
|
type(rpn_t), intent(in) :: b
|
|
type(rpn_t) :: r
|
|
r%zdata = atan2(real(a%zdata),real(b%zdata)) * merge(to_deg,1.0d0,degrees_mode)
|
|
end function atangent2_fr
|
|
|
|
module function round(x) result(r)
|
|
real(8), intent(in) :: x
|
|
real(8) :: r
|
|
if (abs(x) < eps) then
|
|
r = 0
|
|
else
|
|
r = x
|
|
end if
|
|
end function round
|
|
|
|
module subroutine init(lang)
|
|
character(5), intent(in), optional :: lang
|
|
if (present(lang)) decimal = lang
|
|
call set_places(dec_places)
|
|
end subroutine init
|
|
|
|
module subroutine set_places(n)
|
|
integer, intent(in) :: n
|
|
if (n == 0) then
|
|
f_small = 'i0'
|
|
else
|
|
write(f_small,'(2(a,i0),a)') 'f',0,'.',n
|
|
write(f_large,'(2(a,i0),a)') 'en',10+n,'.',n
|
|
end if
|
|
dec_places = n
|
|
end subroutine set_places
|
|
|
|
module function get_places() result(r)
|
|
integer :: r
|
|
r = dec_places
|
|
end function get_places
|
|
|
|
end submodule rpn_sm
|