hp/rpn_stack_sm.f90

! 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