hp/rpn_stack.f90
2023-06-09 21:07:25 +01:00

467 lines
16 KiB
Fortran

module rpn_stack
implicit none
! Type for the data that's going on to the stack
type rpn_t
private
complex(8), private :: zdata = 0
logical, private :: is_cart = .true.
contains
procedure, private :: write_rpns
generic, public :: write(formatted) => write_rpns
procedure :: get_value => get_value_rpns
procedure :: set_value => set_value_rpns
procedure :: is_integer => is_integer_rpns
procedure :: is_real => is_real_rpns
procedure :: is_positive_real => is_positive_real_rpns
procedure :: is_cartesian => is_cartesian_rpns
procedure :: set_angle_unit => set_angle_unit_rpns
procedure, private :: add_rpns
generic, public :: operator(+) => add_rpns
procedure, private :: subtract_rpns
generic, public :: operator(-) => subtract_rpns
procedure, private :: multiply_rpns
generic, public :: operator(*) => multiply_rpns
procedure, private :: divide_rpns
generic, public :: operator(/) => divide_rpns
procedure, private :: power_rpns
generic, public :: operator(**) => power_rpns
procedure, private :: set_to_rpns
generic, public :: assignment(=) => set_to_rpns
end type rpn_t
! Make the stack a parameterized derived type in case we want a different size
type stack_t(ssize)
integer, len :: ssize
private
type(rpn_t) :: sdata(ssize)
character(2) :: legend(ssize)
integer :: high_water = 0
contains
procedure, private :: push_stackt
procedure, private :: push_all_stackt
procedure, private :: push_r_stackt
generic, public :: push => push_stackt, push_all_stackt, push_r_stackt
procedure :: peek => peek_stackt
procedure :: pop => pop_stackt
procedure :: set => set_stackt
procedure :: clear => clear_stackt
procedure :: swap => swap_stackt
procedure :: rotate_up => rotate_up_stackt
procedure :: rotate_down => rotate_down_stackt
procedure :: print => print_stackt
procedure :: get_size => get_size_stackt
procedure :: set_legend => set_legend_stackt
end type stack_t
interface
module subroutine set_legend_stackt(stk, legend)
class(stack_t(*)), intent(inout) :: stk
character(len=2), intent(in) :: legend(:)
end subroutine set_legend_stackt
module function get_size_stackt(stk) result(r)
class(stack_t(*)), intent(in) :: stk
integer :: r
end function get_size_stackt
module subroutine print_stackt(stk, ve_mode)
class(stack_t(*)), intent(in) :: stk
logical, intent(in) :: ve_mode
end subroutine print_stackt
module subroutine push_stackt(stk, z)
class(stack_t(*)), intent(inout) :: stk
type(rpn_t) :: z
end subroutine push_stackt
module subroutine push_r_stackt(stk, x)
class(stack_t(*)), intent(inout) :: stk
real(8) :: x
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
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
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
end function peek_stackt
module function pop_stackt(stk) result(r)
class(stack_t(*)), intent(inout) :: stk
type(rpn_t) :: r
end function pop_stackt
module subroutine clear_stackt(stk)
class(stack_t(*)), intent(inout) :: stk
end subroutine clear_stackt
module subroutine swap_stackt(stk)
class(stack_t(*)), intent(inout) :: stk
end subroutine swap_stackt
module subroutine rotate_up_stackt(stk)
class(stack_t(*)), intent(inout) :: stk
end subroutine rotate_up_stackt
module subroutine rotate_down_stackt(stk)
class(stack_t(*)), intent(inout) :: stk
end subroutine rotate_down_stackt
end interface
interface
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
end subroutine write_rpns
module function is_integer_rpns(this) result(r)
class(rpn_t), intent(in) :: this
logical :: r
end function is_integer_rpns
module function is_cartesian_rpns(this) result(r)
class(rpn_t), intent(in) :: this
logical :: r
end function is_cartesian_rpns
module function is_real_rpns(this) result(r)
class(rpn_t), intent(in) :: this
logical :: r
end function is_real_rpns
module function is_positive_real_rpns(this) result(r)
class(rpn_t), intent(in) :: this
logical :: r
end function is_positive_real_rpns
module subroutine set_angle_unit_rpns(this, degrees)
class(rpn_t), intent(inout) :: this
logical, intent(in) :: degrees
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
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
end subroutine set_value_rpns
module subroutine set_to_rpns(this, z)
class(rpn_t), intent(inout) :: this
type(rpn_t), intent(in) :: z
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
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
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
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
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
end function power_rpns
end interface
real(8), parameter :: pi = 4*atan(1.0d0)
real(8), parameter :: to_rad = pi/180
real(8), parameter :: to_deg = 180/pi
character(5), private :: decimal = 'POINT'
integer :: nroots = 0
type(rpn_t), allocatable :: roots(:)
integer, private :: current_root = 0
character(9), private :: f_large
character(9), private :: f_small
integer :: dec_places = 6
logical :: degrees_mode = .true.
logical :: complex_mode = .false.
real(8) :: eps = 1.0d-14
! Functions interface
interface
module function add_fr(a,b) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t), intent(in) :: b
type(rpn_t) :: r
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
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
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
end function divide_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
end function power_fr
module function percent_fr(a, b) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
type(rpn_t), intent(in) :: b
end function percent_fr
module function power_2_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function power_2_fr
module function power_3_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function power_3_fr
module function sqrt_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function sqrt_fr
module function cbrt_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function cbrt_fr
module function reciprocal_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function reciprocal_fr
module function conj_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function conj_fr
module function len_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function len_fr
module function swap_real_imaginary_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function swap_real_imaginary_fr
module function chs_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function chs_fr
module function sine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function sine_fr
module function cosine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function cosine_fr
module function tangent_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function tangent_fr
module function hsine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function hsine_fr
module function hcosine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function hcosine_fr
module function htangent_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function htangent_fr
module function asine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function asine_fr
module function acosine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function acosine_fr
module function atangent_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function atangent_fr
module function ahsine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function ahsine_fr
module function ahcosine_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function ahcosine_fr
module function ahtangent_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function ahtangent_fr
module function exp_2_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function exp_2_fr
module function exp_e_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function exp_e_fr
module function exp_10_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function exp_10_fr
module function ln_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function ln_fr
module function log2_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function log2_fr
module function lg_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function lg_fr
module function gamma_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function gamma_fr
module function fact_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function fact_fr
module function ncr_fr(a, b) result(r)
type(rpn_t), intent(in) :: a, b
type(rpn_t) :: r
end function ncr_fr
module function npr_fr(a, b) result(r)
type(rpn_t), intent(in) :: a, b
type(rpn_t) :: r
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
end function root_fr
module function next_root_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function next_root_fr
module function previous_root_fr(a) result(r)
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
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
end function atangent2_fr
module function round(x) result(r)
real(8), intent(in) :: x
real(8) ::r
end function round
module subroutine init(lang)
character(5), intent(in), optional :: lang
end subroutine init
module subroutine set_places(n)
integer, intent(in) :: n
end subroutine set_places
module function get_places() result(r)
integer :: r
end function get_places
module subroutine to_string(x, str)
real(8), intent(in) :: x
character(len=:), allocatable, intent(out) :: str
end subroutine to_string
end interface
public
interface to_polar
module function to_polar_rpns(stk_z) result(r)
type(rpn_t), intent(in) :: stk_z
type(rpn_t) :: r
end function to_polar_rpns
end interface
interface to_cartesian
module function to_cartesian_rpns(stk_z) result(r)
type(rpn_t), intent(in) :: stk_z
type(rpn_t) :: r
end function to_cartesian_rpns
end interface
abstract interface
function binary_f(a,b) result(r)
import
type(rpn_t), intent(in) :: a, b
type(rpn_t) :: r
end function binary_f
function unary_f(a) result(r)
import
type(rpn_t), intent(in) :: a
type(rpn_t) :: r
end function unary_f
end interface
end module rpn_stack