1 line
No EOL
186 KiB
JavaScript
1 line
No EOL
186 KiB
JavaScript
var tipuesearch = {"pages":[{"title":" hp ","text":"hp favicon: docs/images/favicon.ico print_creation_date: true\nextra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html\n tomlf:https://toml-f.github.io/toml-f\ncreation_date: %Y-%m-%d %H:%M %z\nmd_extensions: markdown.extensions.toc\n markdown.extensions.smarty hp Command-line calculator This is an rpn calclulator with a maximum stack size of 5. It has full support for real and complex numbers\nand will calculate summary statistics for a set of reals of real pairs. Spaces are important since they are used\nto distinguish tokens. Building The source code is written in Fortran . The only compilers I've found that will build it are ifort and ifx from Intel's\nOneApi suite. Makefiles are provides for GNU make (Linux) and nmake (Windows). hp - h Command Calculator ================== Introduction ------------ This is a command - line calculator . It supports both real and complex modes , as well as degrees / radians selection and precision control . It can be run interactively or as an expression parser . This help is deliberately terse to encourage exploration . ------------------------------------------------------------------------------- Operators : + - * / ^ ^/ x ^ x ^ 2 ^/ 2 ^ 3 ^/ 3 ^* 2 ^* 10 || ! % Constants : pi e g G c two_pi pi_over_2 Functions : sin cos tan asin acos atan sinh cosh tanh log2 log lg len sq sqrt cb cbrt alog2 alog alog10 gamma ncr npr rem int nint Controls : fix [ 0 - 9 ] clx cl cla Modes : real complex verbose terse degrees radians Memories : n = 0. . .9 st < n > sw < n > rc < n > cl < n > m < n >+ m < n >- m < n >* m < n >/ msh Complex : ri _ || to_pol to_cart Actions : 1 / -- R r ? > < split drop Stats : { x1 x2 ... } { x1 , y1 x2 , y2 ... } n ux sx mx lqx uqx uy sy my lqy uqy a b cov corr Quits : q ------------------------------------------------------------------------------- Examples -------- hp \"fix2 18 2 - 8 2 / * =\" -> 64.00 hp \"2 -- complex sqrt =\" -> ( 0.00000 , - 1.414214 ) hp - c \"radians (1,pi_over_2)p ^ * degrees =\" -> ( 1.000000 , 180.000000 ) p Developer Info sgeard","tags":"home","loc":"index.html"},{"title":"rpn_t – hp ","text":"type, public :: rpn_t Contents Type-Bound Procedures assignment(=) get_value is_cartesian is_integer is_positive_real is_real operator(*) operator(**) operator(+) operator(-) operator(/) set_angle_unit set_value write(formatted) Source Code rpn_t Type-Bound Procedures generic, public :: assignment(=) => set_to_rpns public interface set_to_rpns () Arguments None procedure, public :: get_value => get_value_rpns interface public module function get_value_rpns(this, is_cartesian) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this logical, intent(out), optional :: is_cartesian Return Value complex(kind=8) procedure, public :: is_cartesian => is_cartesian_rpns interface public module function is_cartesian_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical procedure, public :: is_integer => is_integer_rpns interface public module function is_integer_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical procedure, public :: is_positive_real => is_positive_real_rpns interface public module function is_positive_real_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical procedure, public :: is_real => is_real_rpns interface public module function is_real_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical generic, public :: operator(*) => multiply_rpns public interface multiply_rpns () Arguments None generic, public :: operator(**) => power_rpns public interface power_rpns () Arguments None generic, public :: operator(+) => add_rpns public interface add_rpns () Arguments None generic, public :: operator(-) => subtract_rpns public interface subtract_rpns () Arguments None generic, public :: operator(/) => divide_rpns public interface divide_rpns () Arguments None procedure, public :: set_angle_unit => set_angle_unit_rpns interface public module subroutine set_angle_unit_rpns(this, degrees) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this logical, intent(in) :: degrees procedure, public :: set_value => set_value_rpns interface public module subroutine set_value_rpns(this, z, is_cartesian) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this complex(kind=8), intent(in), optional :: z logical, intent(in), optional :: is_cartesian generic, public :: write(formatted) => write_rpns public interface write_rpns () Arguments None Source Code 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","tags":"","loc":"type/rpn_t.html"},{"title":"stack_t – hp ","text":"type, public :: stack_t Contents Variables ssize Type-Bound Procedures clear get_size peek pop print push rotate_down rotate_up set set_legend swap Source Code stack_t Components Type Visibility Attributes Name Initial integer, public, len :: ssize Type-Bound Procedures procedure, public :: clear => clear_stackt interface public module subroutine clear_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk procedure, public :: get_size => get_size_stackt interface public module function get_size_stackt(stk) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(in) :: stk Return Value integer procedure, public :: peek => peek_stackt interface public module function peek_stackt(stk, idx) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk integer, intent(in) :: idx Return Value type( rpn_t ) procedure, public :: pop => pop_stackt interface public module function pop_stackt(stk) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk Return Value type( rpn_t ) procedure, public :: print => print_stackt interface public module subroutine print_stackt(stk, ve_mode) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(in) :: stk logical, intent(in) :: ve_mode generic, public :: push => push_stackt, push_all_stackt, push_r_stackt public interface push_stackt () Arguments None public interface push_all_stackt () Arguments None public interface push_r_stackt () Arguments None procedure, public :: rotate_down => rotate_down_stackt interface public module subroutine rotate_down_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk procedure, public :: rotate_up => rotate_up_stackt interface public module subroutine rotate_up_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk procedure, public :: set => set_stackt interface public module subroutine set_stackt(stk, z, idx) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk type( rpn_t ), intent(in) :: z integer, intent(in), optional :: idx procedure, public :: set_legend => set_legend_stackt interface public module subroutine set_legend_stackt(stk, legend) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk character(len=2), intent(in) :: legend (:) procedure, public :: swap => swap_stackt interface public module subroutine swap_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk Source Code 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","tags":"","loc":"type/stack_t.html"},{"title":"llist – hp ","text":"type, public :: llist Contents Type-Bound Procedures iterate Source Code llist Type-Bound Procedures procedure, public :: iterate => iterate_ll public function iterate_ll (this, f) result(r) Arguments Type Intent Optional Attributes Name class( llist ), intent(inout), target :: this procedure( command_fun ) :: f Return Value logical Source Code type llist private type ( llist_node ), pointer :: begin => null () type ( llist_node ), pointer :: end => null () contains procedure :: iterate => iterate_ll end type llist","tags":"","loc":"type/llist.html"},{"title":"llist_node – hp ","text":"type, public :: llist_node Contents Source Code llist_node Source Code type llist_node private character ( len = :), allocatable :: data type ( llist_node ), pointer :: next => null () end type llist_node","tags":"","loc":"type/llist_node.html"},{"title":"amap_t – hp ","text":"type, public :: amap_t Contents Type-Bound Procedures clear contains find get get_value print set Source Code amap_t Type-Bound Procedures procedure, public :: clear => clear_amap_t public subroutine clear_amap_t (this) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(inout) :: this generic, public :: contains => is_key_kt, is_key_kvt public function is_key_kt (this, k) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value logical public function is_key_kvt (this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value logical procedure, public :: find => find_amap_t public function find_amap_t (this, k) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value integer procedure, public :: get => get_amap_t public function get_amap_t (this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value type( value_t ) procedure, public :: get_value => get_value_amap_t public function get_value_amap_t (this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value real(kind=8) procedure, public :: print => print_amap_t public subroutine print_amap_t (this) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this procedure, public :: set => set_amap_t public subroutine set_amap_t (this, kv, vv) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(inout) :: this character(len=*), intent(in) :: kv real(kind=8), intent(in) :: vv Source Code type amap_t private type ( pair_t ), allocatable :: pairs (:) integer , private :: extent = 10 integer , private :: high_water = 0 contains procedure , public :: get => get_amap_t procedure , public :: get_value => get_value_amap_t procedure , public :: set => set_amap_t procedure , public :: find => find_amap_t procedure , public :: print => print_amap_t procedure , public :: clear => clear_amap_t procedure , private :: is_key_kt procedure , private :: is_key_kvt generic , public :: contains => is_key_kt , is_key_kvt end type amap_t","tags":"","loc":"type/amap_t.html"},{"title":"key_t – hp ","text":"type, public :: key_t Contents Type-Bound Procedures assignment(=) operator(==) write(formatted) Source Code key_t Type-Bound Procedures generic, public :: assignment(=) => set_to_key_t public subroutine set_to_key_t (this, k) Arguments Type Intent Optional Attributes Name class( key_t ), intent(inout) :: this character(len=*), intent(in) :: k generic, public :: operator(==) => equals_key_t public function equals_key_t (this, k) result(r) Arguments Type Intent Optional Attributes Name class( key_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value logical generic, public :: write(formatted) => write_key_t public subroutine write_key_t (key, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name class( key_t ), intent(in) :: key integer, intent(in) :: unit character, intent(in) :: iotype integer, intent(in) :: v_list (:) integer, intent(out) :: iostat character, intent(inout) :: iomsg Source Code type key_t private character ( len = 16 ) :: k = '-' contains procedure , private :: equals_key_t generic , public :: operator ( == ) => equals_key_t procedure , private :: write_key_t generic , public :: write ( formatted ) => write_key_t procedure , private :: set_to_key_t generic , public :: assignment ( = ) => set_to_key_t end type key_t","tags":"","loc":"type/key_t.html"},{"title":"pair_t – hp ","text":"type, public :: pair_t Contents Variables k v Source Code pair_t Components Type Visibility Attributes Name Initial type( key_t ), public :: k = key_t() type( value_t ), public :: v = value_t() Source Code type pair_t type ( key_t ) :: k = key_t () type ( value_t ) :: v = value_t () end type pair_t","tags":"","loc":"type/pair_t.html"},{"title":"value_t – hp ","text":"type, public :: value_t Contents Type-Bound Procedures assignment(=) write(formatted) Source Code value_t Type-Bound Procedures generic, public :: assignment(=) => set_to_value_t public subroutine set_to_value_t (this, v) Arguments Type Intent Optional Attributes Name class( value_t ), intent(inout) :: this real(kind=8), intent(in) :: v generic, public :: write(formatted) => write_value_t public subroutine write_value_t (value, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name class( value_t ), intent(in) :: value integer, intent(in) :: unit character, intent(in) :: iotype integer, intent(in) :: v_list (:) integer, intent(out) :: iostat character, intent(inout) :: iomsg Source Code type value_t private real ( 8 ) :: v = huge ( 0.0d0 ) ! An out-of-band value contains procedure , private :: write_value_t generic , public :: write ( formatted ) => write_value_t procedure , private :: set_to_value_t generic , public :: assignment ( = ) => set_to_value_t end type value_t","tags":"","loc":"type/value_t.html"},{"title":"binary_f – hp","text":"abstract interface public function binary_f(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/binary_f.html"},{"title":"unary_f – hp","text":"abstract interface public function unary_f(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/unary_f.html"},{"title":"command_fun – hp","text":"abstract interface public subroutine command_fun(command, ok) Arguments Type Intent Optional Attributes Name character, intent(in) :: command logical, intent(out) :: ok","tags":"","loc":"interface/command_fun.html"},{"title":"acosine_fr – hp","text":"interface public module function acosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/acosine_fr.html"},{"title":"add_fr – hp","text":"interface public module function add_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/add_fr.html"},{"title":"add_rpns – hp","text":"interface public module function add_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/add_rpns.html"},{"title":"ahcosine_fr – hp","text":"interface public module function ahcosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/ahcosine_fr.html"},{"title":"ahsine_fr – hp","text":"interface public module function ahsine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/ahsine_fr.html"},{"title":"ahtangent_fr – hp","text":"interface public module function ahtangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/ahtangent_fr.html"},{"title":"asine_fr – hp","text":"interface public module function asine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/asine_fr.html"},{"title":"atangent2_fr – hp","text":"interface public module function atangent2_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/atangent2_fr.html"},{"title":"atangent_fr – hp","text":"interface public module function atangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/atangent_fr.html"},{"title":"cbrt_fr – hp","text":"interface public module function cbrt_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/cbrt_fr.html"},{"title":"chs_fr – hp","text":"interface public module function chs_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/chs_fr.html"},{"title":"clear_stackt – hp","text":"interface public module subroutine clear_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk","tags":"","loc":"interface/clear_stackt.html"},{"title":"conj_fr – hp","text":"interface public module function conj_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/conj_fr.html"},{"title":"cosine_fr – hp","text":"interface public module function cosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/cosine_fr.html"},{"title":"divide_fr – hp","text":"interface public module function divide_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/divide_fr.html"},{"title":"divide_rpns – hp","text":"interface public module function divide_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/divide_rpns.html"},{"title":"exp_10_fr – hp","text":"interface public module function exp_10_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/exp_10_fr.html"},{"title":"exp_2_fr – hp","text":"interface public module function exp_2_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/exp_2_fr.html"},{"title":"exp_e_fr – hp","text":"interface public module function exp_e_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/exp_e_fr.html"},{"title":"fact_fr – hp","text":"interface public module function fact_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/fact_fr.html"},{"title":"gamma_fr – hp","text":"interface public module function gamma_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/gamma_fr.html"},{"title":"get_places – hp","text":"interface public module function get_places() result(r) Arguments None Return Value integer","tags":"","loc":"interface/get_places.html"},{"title":"get_size_stackt – hp","text":"interface public module function get_size_stackt(stk) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(in) :: stk Return Value integer","tags":"","loc":"interface/get_size_stackt.html"},{"title":"get_value_rpns – hp","text":"interface public module function get_value_rpns(this, is_cartesian) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this logical, intent(out), optional :: is_cartesian Return Value complex(kind=8)","tags":"","loc":"interface/get_value_rpns.html"},{"title":"hcosine_fr – hp","text":"interface public module function hcosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/hcosine_fr.html"},{"title":"hsine_fr – hp","text":"interface public module function hsine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/hsine_fr.html"},{"title":"htangent_fr – hp","text":"interface public module function htangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/htangent_fr.html"},{"title":"init – hp","text":"interface public module subroutine init(lang) Arguments Type Intent Optional Attributes Name character(len=5), intent(in), optional :: lang","tags":"","loc":"interface/init.html"},{"title":"is_cartesian_rpns – hp","text":"interface public module function is_cartesian_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical","tags":"","loc":"interface/is_cartesian_rpns.html"},{"title":"is_integer_rpns – hp","text":"interface public module function is_integer_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical","tags":"","loc":"interface/is_integer_rpns.html"},{"title":"is_positive_real_rpns – hp","text":"interface public module function is_positive_real_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical","tags":"","loc":"interface/is_positive_real_rpns.html"},{"title":"is_real_rpns – hp","text":"interface public module function is_real_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical","tags":"","loc":"interface/is_real_rpns.html"},{"title":"len_fr – hp","text":"interface public module function len_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/len_fr.html"},{"title":"lg_fr – hp","text":"interface public module function lg_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/lg_fr.html"},{"title":"ln_fr – hp","text":"interface public module function ln_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/ln_fr.html"},{"title":"log2_fr – hp","text":"interface public module function log2_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/log2_fr.html"},{"title":"multiply_fr – hp","text":"interface public module function multiply_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/multiply_fr.html"},{"title":"multiply_rpns – hp","text":"interface public module function multiply_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/multiply_rpns.html"},{"title":"ncr_fr – hp","text":"interface public module function ncr_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/ncr_fr.html"},{"title":"next_root_fr – hp","text":"interface public module function next_root_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/next_root_fr.html"},{"title":"npr_fr – hp","text":"interface public module function npr_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/npr_fr.html"},{"title":"peek_stackt – hp","text":"interface public module function peek_stackt(stk, idx) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk integer, intent(in) :: idx Return Value type( rpn_t )","tags":"","loc":"interface/peek_stackt.html"},{"title":"percent_fr – hp","text":"interface public module function percent_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/percent_fr.html"},{"title":"pop_stackt – hp","text":"interface public module function pop_stackt(stk) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk Return Value type( rpn_t )","tags":"","loc":"interface/pop_stackt.html"},{"title":"power_2_fr – hp","text":"interface public module function power_2_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/power_2_fr.html"},{"title":"power_3_fr – hp","text":"interface public module function power_3_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/power_3_fr.html"},{"title":"power_fr – hp","text":"interface public module function power_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/power_fr.html"},{"title":"power_rpns – hp","text":"interface public module function power_rpns(this, x) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this real(kind=8), intent(in) :: x Return Value type( rpn_t )","tags":"","loc":"interface/power_rpns.html"},{"title":"previous_root_fr – hp","text":"interface public module function previous_root_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/previous_root_fr.html"},{"title":"print_stackt – hp","text":"interface public module subroutine print_stackt(stk, ve_mode) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(in) :: stk logical, intent(in) :: ve_mode","tags":"","loc":"interface/print_stackt.html"},{"title":"push_all_stackt – hp","text":"interface public module subroutine push_all_stackt(stk, z, is_cart) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk complex(kind=8), intent(in) :: z logical, intent(in), optional :: is_cart","tags":"","loc":"interface/push_all_stackt.html"},{"title":"push_r_stackt – hp","text":"interface public module subroutine push_r_stackt(stk, x) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk real(kind=8) :: x","tags":"","loc":"interface/push_r_stackt.html"},{"title":"push_stackt – hp","text":"interface public module subroutine push_stackt(stk, z) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk type( rpn_t ) :: z","tags":"","loc":"interface/push_stackt.html"},{"title":"reciprocal_fr – hp","text":"interface public module function reciprocal_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/reciprocal_fr.html"},{"title":"root_fr – hp","text":"interface public module function root_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/root_fr.html"},{"title":"rotate_down_stackt – hp","text":"interface public module subroutine rotate_down_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk","tags":"","loc":"interface/rotate_down_stackt.html"},{"title":"rotate_up_stackt – hp","text":"interface public module subroutine rotate_up_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk","tags":"","loc":"interface/rotate_up_stackt.html"},{"title":"round – hp","text":"interface public module function round(x) result(r) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: x Return Value real(kind=8)","tags":"","loc":"interface/round.html"},{"title":"set_angle_unit_rpns – hp","text":"interface public module subroutine set_angle_unit_rpns(this, degrees) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this logical, intent(in) :: degrees","tags":"","loc":"interface/set_angle_unit_rpns.html"},{"title":"set_legend_stackt – hp","text":"interface public module subroutine set_legend_stackt(stk, legend) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk character(len=2), intent(in) :: legend (:)","tags":"","loc":"interface/set_legend_stackt.html"},{"title":"set_places – hp","text":"interface public module subroutine set_places(n) Arguments Type Intent Optional Attributes Name integer, intent(in) :: n","tags":"","loc":"interface/set_places.html"},{"title":"set_stackt – hp","text":"interface public module subroutine set_stackt(stk, z, idx) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk type( rpn_t ), intent(in) :: z integer, intent(in), optional :: idx","tags":"","loc":"interface/set_stackt.html"},{"title":"set_to_rpns – hp","text":"interface public module subroutine set_to_rpns(this, z) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this type( rpn_t ), intent(in) :: z","tags":"","loc":"interface/set_to_rpns.html"},{"title":"set_value_rpns – hp","text":"interface public module subroutine set_value_rpns(this, z, is_cartesian) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this complex(kind=8), intent(in), optional :: z logical, intent(in), optional :: is_cartesian","tags":"","loc":"interface/set_value_rpns.html"},{"title":"sine_fr – hp","text":"interface public module function sine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/sine_fr.html"},{"title":"sqrt_fr – hp","text":"interface public module function sqrt_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/sqrt_fr.html"},{"title":"subtract_fr – hp","text":"interface public module function subtract_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/subtract_fr.html"},{"title":"subtract_rpns – hp","text":"interface public module function subtract_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t )","tags":"","loc":"interface/subtract_rpns.html"},{"title":"swap_real_imaginary_fr – hp","text":"interface public module function swap_real_imaginary_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/swap_real_imaginary_fr.html"},{"title":"swap_stackt – hp","text":"interface public module subroutine swap_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk","tags":"","loc":"interface/swap_stackt.html"},{"title":"tangent_fr – hp","text":"interface public module function tangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t )","tags":"","loc":"interface/tangent_fr.html"},{"title":"to_cartesian – hp","text":"public interface to_cartesian Contents Functions to_cartesian_rpns Functions public module function to_cartesian_rpns(stk_z) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: stk_z Return Value type( rpn_t )","tags":"","loc":"interface/to_cartesian.html"},{"title":"to_polar – hp","text":"public interface to_polar Contents Functions to_polar_rpns Functions public module function to_polar_rpns(stk_z) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: stk_z Return Value type( rpn_t )","tags":"","loc":"interface/to_polar.html"},{"title":"to_string – hp","text":"interface public module subroutine to_string(x, str) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: x character(len=:), intent(out), allocatable :: str","tags":"","loc":"interface/to_string.html"},{"title":"write_rpns – hp","text":"interface public module subroutine write_rpns(se, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name 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","tags":"","loc":"interface/write_rpns.html"},{"title":"iterate_ll – hp","text":"public function iterate_ll(this, f) result(r) Arguments Type Intent Optional Attributes Name class( llist ), intent(inout), target :: this procedure( command_fun ) :: f Return Value logical Contents Variables token Source Code iterate_ll Variables Type Visibility Attributes Name Initial type( llist_node ), public, pointer :: token Source Code function iterate_ll ( this , f ) result ( r ) class ( llist ), intent ( inout ), target :: this procedure ( command_fun ) :: f logical :: r type ( llist_node ), pointer :: token token => this % begin do if (. not . associated ( token )) exit call f ( trim ( token % data ), r ) if (. not . r ) then exit end if token => token % next end do end function iterate_ll","tags":"","loc":"proc/iterate_ll.html"},{"title":"size – hp","text":"public function size(lst) Arguments Type Intent Optional Attributes Name type( llist ), intent(inout) :: lst Return Value integer Contents Variables this Source Code size Variables Type Visibility Attributes Name Initial type( llist_node ), public, pointer :: this Source Code integer function size ( lst ) type ( llist ), intent ( inout ) :: lst type ( llist_node ), pointer :: this size = 0 this => lst % begin do if (. not . associated ( this )) exit size = size + 1 this => this % next end do end function size","tags":"","loc":"proc/size.html"},{"title":"append – hp","text":"public subroutine append(lst, data) Arguments Type Intent Optional Attributes Name type( llist ), intent(inout) :: lst character, intent(in) :: data Contents Source Code append Source Code subroutine append ( lst , data ) type ( llist ), intent ( inout ) :: lst character ( * ), intent ( in ) :: data if (. not . associated ( lst % begin )) then allocate ( lst % begin ) lst % begin % data = data lst % end => lst % begin else allocate ( lst % end % next ) lst % end % next % data = data lst % end => lst % end % next end if end subroutine append","tags":"","loc":"proc/append.html"},{"title":"clear – hp","text":"public subroutine clear(lst) Arguments Type Intent Optional Attributes Name type( llist ), intent(inout) :: lst Contents Variables next this Source Code clear Variables Type Visibility Attributes Name Initial type( llist_node ), public, pointer :: next type( llist_node ), public, pointer :: this Source Code subroutine clear ( lst ) type ( llist ), intent ( inout ) :: lst type ( llist_node ), pointer :: this , next this => lst % begin do if (. not . associated ( this )) exit next => this % next deallocate ( this ) this => next end do nullify ( lst % end ) nullify ( lst % begin ) end subroutine clear","tags":"","loc":"proc/clear.html"},{"title":"print – hp","text":"public subroutine print(lst) Arguments Type Intent Optional Attributes Name type( llist ), intent(in) :: lst Contents Variables next Source Code print Variables Type Visibility Attributes Name Initial type( llist_node ), public, pointer :: next Source Code subroutine print ( lst ) type ( llist ), intent ( in ) :: lst type ( llist_node ), pointer :: next write ( * , '(a)' ) 'Tokens:' next => lst % begin do if (. not . associated ( next )) exit write ( * , '(4x,a)' ) next % data next => next % next end do end subroutine print","tags":"","loc":"proc/print.html"},{"title":"equals_key_t – hp","text":"public function equals_key_t(this, k) result(r) Arguments Type Intent Optional Attributes Name class( key_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value logical Contents Source Code equals_key_t Source Code function equals_key_t ( this , k ) result ( r ) class ( key_t ), intent ( in ) :: this type ( key_t ), intent ( in ) :: k logical :: r r = trim ( adjustl ( this % k )) == trim ( adjustl ( k % k )) end function equals_key_t","tags":"","loc":"proc/equals_key_t.html"},{"title":"find_amap_t – hp","text":"public function find_amap_t(this, k) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value integer Contents Source Code find_amap_t Source Code function find_amap_t ( this , k ) result ( r ) class ( amap_t ), intent ( in ) :: this type ( key_t ), intent ( in ) :: k integer :: r do r = 1 , this % high_water if ( this % pairs ( r )% k == k ) then return end if end do r = 0 end function find_amap_t","tags":"","loc":"proc/find_amap_t.html"},{"title":"get_amap_t – hp","text":"public function get_amap_t(this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value type( value_t ) Contents Variables idx k Source Code get_amap_t Variables Type Visibility Attributes Name Initial integer, public :: idx type( key_t ), public :: k Source Code function get_amap_t ( this , kv ) result ( r ) class ( amap_t ), intent ( in ) :: this character ( len =* ), intent ( in ) :: kv type ( value_t ) :: r type ( key_t ) :: k integer :: idx k = kv idx = this % find ( k ) if ( idx > 0 ) then r = this % pairs ( idx )% v else r = value_t () end if end function get_amap_t","tags":"","loc":"proc/get_amap_t.html"},{"title":"get_value_amap_t – hp","text":"public function get_value_amap_t(this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value real(kind=8) Contents Variables s Source Code get_value_amap_t Variables Type Visibility Attributes Name Initial type( value_t ), public :: s Source Code function get_value_amap_t ( this , kv ) result ( r ) class ( amap_t ), intent ( in ) :: this character ( len =* ), intent ( in ) :: kv real ( 8 ) :: r type ( value_t ) :: s s = this % get ( kv ) r = s % v end function get_value_amap_t","tags":"","loc":"proc/get_value_amap_t.html"},{"title":"is_key_kt – hp","text":"public function is_key_kt(this, k) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value logical Contents Source Code is_key_kt Source Code function is_key_kt ( this , k ) result ( r ) class ( amap_t ), intent ( in ) :: this type ( key_t ), intent ( in ) :: k logical :: r r = this % find ( k ) > 0 end function is_key_kt","tags":"","loc":"proc/is_key_kt.html"},{"title":"is_key_kvt – hp","text":"public function is_key_kvt(this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value logical Contents Source Code is_key_kvt Source Code function is_key_kvt ( this , kv ) result ( r ) class ( amap_t ), intent ( in ) :: this character ( len =* ), intent ( in ) :: kv logical :: r r = this % find ( key_t ( kv )) > 0 end function is_key_kvt","tags":"","loc":"proc/is_key_kvt.html"},{"title":"clear_amap_t – hp","text":"public subroutine clear_amap_t(this) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(inout) :: this Contents Source Code clear_amap_t Source Code subroutine clear_amap_t ( this ) class ( amap_t ), intent ( inout ) :: this if ( allocated ( this % pairs )) then deallocate ( this % pairs ) end if this % high_water = 0 end subroutine clear_amap_t","tags":"","loc":"proc/clear_amap_t.html"},{"title":"print_amap_t – hp","text":"public subroutine print_amap_t(this) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this Contents Variables i Source Code print_amap_t Variables Type Visibility Attributes Name Initial integer, public :: i Source Code subroutine print_amap_t ( this ) class ( amap_t ), intent ( in ) :: this integer :: i write ( 6 , '(a,i0,a)' ) 'Map has ' , this % high_water , ' elements' do i = 1 , this % high_water write ( 6 , '(4x,dt,a,dt)' ) this % pairs ( i )% k , ' -> ' , this % pairs ( i )% v end do end subroutine print_amap_t","tags":"","loc":"proc/print_amap_t.html"},{"title":"set_amap_t – hp","text":"public subroutine set_amap_t(this, kv, vv) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(inout) :: this character(len=*), intent(in) :: kv real(kind=8), intent(in) :: vv Contents Variables idx k tmp_pairs v Source Code set_amap_t Variables Type Visibility Attributes Name Initial integer, public :: idx type( key_t ), public :: k type( pair_t ), public, allocatable :: tmp_pairs (:) type( value_t ), public :: v Source Code subroutine set_amap_t ( this , kv , vv ) class ( amap_t ), intent ( inout ) :: this character ( len =* ), intent ( in ) :: kv real ( 8 ), intent ( in ) :: vv type ( pair_t ), allocatable :: tmp_pairs (:) type ( key_t ) :: k type ( value_t ) :: v integer :: idx k = kv v = vv if (. not . allocated ( this % pairs )) then allocate ( this % pairs ( this % extent )) end if idx = this % find ( k ) if ( idx > 0 ) then this % pairs ( idx ) = pair_t ( k , v ) return end if if ( this % high_water == size ( this % pairs )) then allocate ( tmp_pairs ( size ( this % pairs ) + this % extent )) tmp_pairs ( 1 : this % high_water ) = this % pairs call move_alloc ( tmp_pairs , this % pairs ) end if this % high_water = this % high_water + 1 this % pairs ( this % high_water ) = pair_t ( k , v ) end subroutine set_amap_t","tags":"","loc":"proc/set_amap_t.html"},{"title":"set_to_key_t – hp","text":"public subroutine set_to_key_t(this, k) Arguments Type Intent Optional Attributes Name class( key_t ), intent(inout) :: this character(len=*), intent(in) :: k Contents Source Code set_to_key_t Source Code subroutine set_to_key_t ( this , k ) class ( key_t ), intent ( inout ) :: this character ( len =* ), intent ( in ) :: k this % k = adjustl ( k ) end subroutine set_to_key_t","tags":"","loc":"proc/set_to_key_t.html"},{"title":"set_to_value_t – hp","text":"public subroutine set_to_value_t(this, v) Arguments Type Intent Optional Attributes Name class( value_t ), intent(inout) :: this real(kind=8), intent(in) :: v Contents Source Code set_to_value_t Source Code subroutine set_to_value_t ( this , v ) class ( value_t ), intent ( inout ) :: this real ( 8 ), intent ( in ) :: v this % v = v end subroutine set_to_value_t","tags":"","loc":"proc/set_to_value_t.html"},{"title":"write_key_t – hp","text":"public subroutine write_key_t(key, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name class( key_t ), intent(in) :: key integer, intent(in) :: unit character, intent(in) :: iotype integer, intent(in) :: v_list (:) integer, intent(out) :: iostat character, intent(inout) :: iomsg Contents Source Code write_key_t Source Code subroutine write_key_t ( key , unit , iotype , v_list , iostat , iomsg ) class ( key_t ), intent ( in ) :: key integer , intent ( in ) :: unit character ( * ), intent ( in ) :: iotype integer , intent ( in ) :: v_list (:) integer , intent ( out ) :: iostat character ( * ), intent ( inout ) :: iomsg iostat = 0 !iomsg = \"\" write ( 6 , '(a)' , iostat = iostat , iomsg = iomsg ) trim ( adjustl ( key % k )) end subroutine write_key_t","tags":"","loc":"proc/write_key_t.html"},{"title":"write_value_t – hp","text":"public subroutine write_value_t(value, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name class( value_t ), intent(in) :: value integer, intent(in) :: unit character, intent(in) :: iotype integer, intent(in) :: v_list (:) integer, intent(out) :: iostat character, intent(inout) :: iomsg Contents Source Code write_value_t Source Code subroutine write_value_t ( value , unit , iotype , v_list , iostat , iomsg ) class ( value_t ), intent ( in ) :: value integer , intent ( in ) :: unit character ( * ), intent ( in ) :: iotype integer , intent ( in ) :: v_list (:) integer , intent ( out ) :: iostat character ( * ), intent ( inout ) :: iomsg iostat = 0 !iomsg = \"\" write ( 6 , '(f0.6)' , iostat = iostat , iomsg = iomsg ) value % v end subroutine write_value_t","tags":"","loc":"proc/write_value_t.html"},{"title":"calc_median – hp","text":"function calc_median(a, mid) result(r) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: a (:) integer, intent(out), optional :: mid Return Value real(kind=8) Contents Variables m n Source Code calc_median Variables Type Visibility Attributes Name Initial integer, public :: m integer, public :: n Source Code function calc_median ( a , mid ) result ( r ) real ( 8 ), intent ( in ) :: a (:) integer , intent ( out ), optional :: mid real ( 8 ) :: r integer :: m , n n = size ( a ) m = n / 2 if ( mod ( n , 2 ) == 0 ) then r = ( a ( m ) + a ( m + 1 )) / 2.0d0 else m = m + 1 r = a ( m ) end if if ( present ( mid )) then mid = m end if end function calc_median","tags":"","loc":"proc/calc_median.html"},{"title":"nsp – hp","text":"function nsp(command) Arguments Type Intent Optional Attributes Name character, intent(in) :: command Return Value integer Contents Variables i Source Code nsp Variables Type Visibility Attributes Name Initial integer, public :: i Source Code integer function nsp ( command ) implicit none character ( * ), intent ( in ) :: command integer :: i do i = 1 , len ( command ) if ( command ( i : i ) /= ' ' ) then nsp = i return end if end do nsp = 0 end function nsp","tags":"","loc":"proc/nsp.html"},{"title":"apply_command – hp","text":"subroutine apply_command(command, ok) Uses ieee_arithmetic Arguments Type Intent Optional Attributes Name character, intent(in) :: command logical, intent(out) :: ok Contents Variables ang comma idx im is_cart lang m r tmp_seq u us z zs Source Code apply_command Variables Type Visibility Attributes Name Initial real(kind=8), public :: ang character(len=1), public :: comma integer, public :: idx real(kind=8), public :: im logical, public :: is_cart character(len=5), public, parameter :: lang (2) = ['POINT', 'COMMA'] integer, public :: m real(kind=8), public :: r real(kind=8), public, allocatable :: tmp_seq (:) complex(kind=8), public :: u type( rpn_t ), public :: us complex(kind=8), public :: z type( rpn_t ), public :: zs Source Code subroutine apply_command ( command , ok ) use , intrinsic :: ieee_arithmetic implicit none character ( * ), intent ( in ) :: command logical , intent ( out ) :: ok real ( 8 ) :: r , im , ang complex ( 8 ) :: u , z real ( 8 ), allocatable :: tmp_seq (:) type ( rpn_t ) :: us , zs logical :: is_cart integer :: m , idx character ( len = 1 ) :: comma character ( 5 ), parameter :: lang ( 2 ) = [ 'POINT' , 'COMMA' ] ok = . true . if ( len_trim ( command ) == 0 ) then return end if if ( verbosity > 0 ) then write ( * , '(a)' ) 'Applying: ' // command end if if ( in_sequence == 1 ) then if ( command == '}' ) then in_sequence = 2 complex_mode = tmp_cmode call calculate_stats else ! All elements must be the same so either all x or all x,y idx = index ( command , ',' ) if ( n_seq == 0 ) then seq_is_x = ( idx == 0 ) end if if ( seq_is_x . neqv . ( idx == 0 )) then goto 901 end if if ( seq_is_x ) then read ( command , * , err = 901 ) r im = 0 else read ( command ( 1 : idx - 1 ), * , err = 901 ) r read ( command ( idx + 1 : len ( command )), * , err = 901 ) im end if ! Initial allocation if ( n_seq == 0 . and . . not . allocated ( x_seq )) then allocate ( x_seq ( 10 )) if (. not . seq_is_x ) then allocate ( y_seq ( 10 )) end if end if if ( n_seq < size ( x_seq )) then n_seq = n_seq + 1 else ! Expand array allocate ( tmp_seq ( n_seq + 10 )) tmp_seq ( 1 : n_seq ) = x_seq call move_alloc ( tmp_seq , x_seq ) if (. not . seq_is_x ) then allocate ( tmp_seq ( n_seq + 10 )) tmp_seq ( 1 : n_seq ) = y_seq call move_alloc ( tmp_seq , y_seq ) end if end if x_seq ( n_seq ) = r if (. not . seq_is_x ) then y_seq ( n_seq ) = im end if if ( verbosity > 0 ) then print * , x_seq ( 1 : n_seq ) end if end if return end if select case ( command ) case ( 'q' , 'quit' ) ok = . false . return case ( '=' ) ok = . false . return case ( '{' ) ! Start sequence in_sequence = 1 n_seq = 0 tmp_cmode = complex_mode complex_mode = . false . call stats % clear () case ( '--' ) call invoke_unary ( chs_fr ) case ( '^' ) call stack % push ( stack % peek ( 1 )) case ( '+' ) call invoke_binary ( add_fr ) case ( '-' ) call invoke_binary ( subtract_fr ) case ( '*' ) call invoke_binary ( multiply_fr ) case ( '/' ) call invoke_binary ( divide_fr ) case ( '^x' ) call invoke_binary ( power_fr ) case ( '^/x' ) ! Only raising to a real power is supported zs = stack % peek ( 1 ) if ( zs % is_real ()) then call invoke_binary ( root_fr ) else goto 901 end if case ( '>' ) call invoke_unary ( next_root_fr ) case ( '<' ) call invoke_unary ( previous_root_fr ) case ( '%' ) call invoke_binary ( percent_fr ) case ( 'xy' , 'XY' ) call stack % swap case ( 'R' ) call stack % rotate_down case ( 'r' ) call stack % rotate_up case ( 'CLA' , 'cla' ) call stack % clear mem = rpn_t () call stats % clear case ( 'CL' , 'cl' ) call stack % clear case ( 'CLX' , 'clx' ) call stack % set ( rpn_t ()) case ( '_' ) if ( complex_mode ) then call invoke_unary ( conj_fr ) endif case ( 'len' , '||' ) if ( complex_mode ) then call invoke_unary ( len_fr ) ! Length is always reported as (x,0) and marked is_cartesian zs = stack % peek ( 1 ) call zs % set_value ( is_cartesian = . true .) call stack % set ( zs , 1 ) else zs = stack % peek ( 1 ) z = zs % get_value () us = stack % peek ( 2 ) u = us % get_value () call zs % set_value ( cmplx ( hypot ( z % re , u % re ), 0 , 8 )) call stack % set ( zs ) end if case ( 'split' ) if (. not . complex_mode ) then zs = stack % pop () x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if im = x - r call stack % push ( im ) call stack % push ( r ) end if case ( 'int' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if call zs % set_value ( cmplx ( r , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'nint' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () r = nint ( x ) if ( mod ( r , 2.0d0 ) == 1 ) then r = r - 1 end if call zs % set_value ( cmplx ( r , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'rem' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if im = x - r call zs % set_value ( cmplx ( im , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'drop' ) zs = stack % pop () case ( 'ri' ) ! Swap real and imaginary parts if ( complex_mode ) then call invoke_unary ( swap_real_imaginary_fr ) end if case ( 'to_pol' ) ! Convert x + iy to r + i theta if ( complex_mode ) then zs = stack % peek ( 1 ) call stack % set ( to_polar ( zs )) end if case ( 'to_cart' ) ! Convert (r,theta) to (x,y) if ( complex_mode ) then zs = stack % peek ( 1 ) call stack % set ( to_cartesian ( zs )) end if case ( '1/' ) call invoke_unary ( reciprocal_fr ) case ( '^2' , 'sq' ) call invoke_unary ( power_2_fr ) case ( '^/2' , 'sqrt' ) call invoke_unary ( sqrt_fr ) case ( '^3' , 'cb' ) call invoke_unary ( power_3_fr ) case ( '^/3' , 'cbrt' ) call invoke_unary ( cbrt_fr ) case ( '^*2' , 'alog2' ) call invoke_unary ( exp_2_fr ) case ( '^*10' , 'alog10' ) call invoke_unary ( exp_10_fr ) case ( 'exp' , 'alog' ) call invoke_unary ( exp_e_fr ) case ( 'ln' ) call invoke_unary ( ln_fr ) case ( 'log2' ) call invoke_unary ( log2_fr ) case ( 'lg' ) call invoke_unary ( lg_fr ) case ( 'sinh' ) call invoke_unary ( hsine_fr ) case ( 'cosh' ) call invoke_unary ( hcosine_fr ) case ( 'tanh' ) call invoke_unary ( htangent_fr ) case ( 'sin' ) call invoke_unary ( sine_fr ) case ( 'cos' ) call invoke_unary ( cosine_fr ) case ( 'tan' ) call invoke_unary ( tangent_fr ) case ( 'asin' ) call invoke_unary ( asine_fr ) case ( 'asinh' ) call invoke_unary ( ahsine_fr ) case ( 'acos' ) call invoke_unary ( acosine_fr ) case ( 'acosh' ) call invoke_unary ( ahcosine_fr ) case ( 'atan' ) call invoke_unary ( atangent_fr ) case ( 'atanh' ) call invoke_unary ( ahtangent_fr ) case ( 'atan2' ) call invoke_binary ( atangent2_fr ) case ( 'gamma' ) call invoke_unary ( gamma_fr ) case ( '!' ) zs = stack % peek ( 1 ) if ( zs % is_positive_real ()) then call invoke_unary ( fact_fr ) else goto 901 end if case ( 'ncr' ) zs = stack % peek ( 1 ) us = stack % peek ( 2 ) if ( zs % is_positive_real () . and . us % is_positive_real ()) then call invoke_binary ( ncr_fr ) else goto 901 end if case ( 'npr' ) zs = stack % peek ( 1 ) us = stack % peek ( 2 ) if ( zs % is_positive_real () . and . us % is_positive_real ()) then call invoke_binary ( npr_fr ) else goto 901 end if case ( 'm0+' , 'm1+' , 'm2+' , 'm3+' , 'm4+' , 'm5+' , 'm6+' , 'm7+' , 'm8+' , 'm9+' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) + stack % peek ( 1 ) case ( 'm0-' , 'm1-' , 'm2-' , 'm3-' , 'm4-' , 'm5-' , 'm6-' , 'm7-' , 'm8-' , 'm9-' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) - stack % peek ( 1 ) case ( 'm0*' , 'm1*' , 'm2*' , 'm3*' , 'm4*' , 'm5*' , 'm6*' , 'm7*' , 'm8*' , 'm9*' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) * stack % peek ( 1 ) case ( 'm0/' , 'm1/' , 'm2/' , 'm3/' , 'm4/' , 'm5/' , 'm6/' , 'm7/' , 'm8/' , 'm9/' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) / stack % peek ( 1 ) case ( 'st0' , 'st1' , 'st2' , 'st3' , 'st4' , 'st5' , 'st6' , 'st7' , 'st8' , 'st9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m mem ( m ) = stack % peek ( 1 ) case ( 'sw0' , 'sw1' , 'sw2' , 'sw3' , 'sw4' , 'sw5' , 'sw6' , 'sw7' , 'sw8' , 'sw9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m zs = stack % peek ( 1 ) call stack % set ( mem ( m )) mem ( m ) = zs case ( 'rc0' , 'rc1' , 'rc2' , 'rc3' , 'rc4' , 'rc5' , 'rc6' , 'rc7' , 'rc8' , 'rc9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m call stack % push ( mem ( m )) case ( 'cl0' , 'cl1' , 'cl2' , 'cl3' , 'cl4' , 'cl5' , 'cl6' , 'cl7' , 'cl8' , 'cl9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m mem ( m ) = rpn_t () case ( 'msh' ) write ( 6 , '(i3,a,dt)' ) ( i , ': ' , mem ( i ), i = 0 , size ( mem ) - 1 ) case ( 'fix0' , 'fix1' , 'fix2' , 'fix3' , 'fix4' , 'fix5' , 'fix6' , 'fix7' , 'fix8' , 'fix9' ) read ( command ( 4 : 4 ), '(i1)' ) m call set_places ( m ) case ( 'DEG' , 'deg' , 'DEGREES' , 'degrees' ) call toggle_degrees_mode (. true .) case ( 'RAD' , 'rad' , 'RADIANS' , 'radians' ) call toggle_degrees_mode (. false .) case ( 'mC' , 'COMPLEX' , 'complex' ) complex_mode = . true . case ( 'mR' , 'REAL' , 'real' ) complex_mode = . false . case ( 'mV' , 'VERBOSE' , 'verbose' ) veMode = . true . case ( 'mT' , 'TERSE' , 'terse' ) veMode = . false . case ( '?' ) write ( 6 , advance = 'no' , fmt = '(a)' ) 'Status: ' write ( 6 , advance = 'no' , fmt = '(2a)' ) merge ( 'degrees' , 'radians' , degrees_mode ), ' ; ' write ( 6 , advance = 'no' , fmt = '(a,i0)' ) 'dp = ' , get_places () if ( complex_mode ) then write ( 6 , advance = 'no' , fmt = '(a)' ) ' ; mode = complex' else write ( 6 , advance = 'no' , fmt = '(a)' ) ' ; mode = real' end if write ( 6 , advance = 'no' , fmt = '(a,i0)' ) ' ; stack size = ' , stack % get_size () write ( 6 , '(a/)' ) '' case ( 'help' , 'h' ) call help case default ! Process constants first block integer :: lc , is_integer , split_idx , end_idx character ( len = :), allocatable :: re_comp , im_comp lc = len_trim ( command ) is_integer = ( index ( command , '.' ) == 0 ) if ( complex_mode ) then if ( command ( 1 : 1 ) == '(' ) then split_idx = index ( command , ',' ) end_idx = index ( command , ')' ) re_comp = command ( 2 : split_idx - 1 ) im_comp = command ( split_idx + 1 : end_idx - 1 ) if ( constants % contains ( re_comp )) then z % re = constants % get_value ( re_comp ) else read ( re_comp , * , err = 901 , end = 901 ) z % re end if if ( constants % contains ( im_comp )) then z % im = constants % get_value ( im_comp ) else read ( im_comp , * , err = 901 , end = 901 ) z % im end if if ( command ( lc : lc ) == 'p' ) then call stack % push ( z ,. false .) else call stack % push ( z ) end if else if ( constants % contains ( command )) then x = constants % get_value ( command ) else read ( command , * , err = 901 , end = 901 ) x end if call stack % push ( cmplx ( x , 0.0d0 , 8 )) end if else if ( constants % contains ( command )) then x = constants % get_value ( command ) else if ( stats % contains ( command )) then x = stats % get_value ( command ) else read ( command , * , err = 901 , end = 901 ) x end if call stack % push ( cmplx ( x , 0.0d0 , 8 )) end if end block end select return 901 continue write ( 6 , '(a)' ) command // ' ???' return end subroutine apply_command","tags":"","loc":"proc/apply_command.html"},{"title":"calculate_regression – hp","text":"subroutine calculate_regression(mean_x, mean_y, a, b, c, sxy) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: mean_x real(kind=8), intent(in) :: mean_y real(kind=8), intent(out) :: a real(kind=8), intent(out) :: b real(kind=8), intent(out) :: c real(kind=8), intent(out) :: sxy Contents Variables i sxx syy Source Code calculate_regression Variables Type Visibility Attributes Name Initial integer, public :: i real(kind=8), public :: sxx real(kind=8), public :: syy Source Code subroutine calculate_regression ( mean_x , mean_y , a , b , c , sxy ) real ( 8 ), intent ( in ) :: mean_x , mean_y real ( 8 ), intent ( out ) :: a , b , c , sxy integer :: i real ( 8 ) :: sxx , syy sxy = sum ( x_seq ( 1 : n_seq ) * y_seq ( 1 : n_seq )) / n_seq - mean_x * mean_y sxx = sum ( x_seq ( 1 : n_seq ) * x_seq ( 1 : n_seq )) / n_seq - mean_x ** 2 syy = sum ( y_seq ( 1 : n_seq ) * y_seq ( 1 : n_seq )) / n_seq - mean_y ** 2 a = sxy / sxx b = mean_y - a * mean_x c = sxy / sqrt ( sxx * syy ) end subroutine calculate_regression","tags":"","loc":"proc/calculate_regression.html"},{"title":"calculate_stats – hp","text":"subroutine calculate_stats() Arguments None Contents Variables a b c s sxy Source Code calculate_stats Variables Type Visibility Attributes Name Initial real(kind=8), public :: a real(kind=8), public :: b real(kind=8), public :: c real(kind=8), public :: s (5,2) real(kind=8), public :: sxy Source Code subroutine calculate_stats real ( 8 ) :: a , b , c , sxy real ( 8 ) :: s ( 5 , 2 ) call summary_stats ( x_seq ( 1 : n_seq ), s ( 1 , 1 ), s ( 2 , 1 ), s ( 3 , 1 ), s ( 4 , 1 ), s ( 5 , 1 )) call stats % set ( 'n' , real ( n_seq , 8 )) call stats % set ( 'ux' , s ( 1 , 1 )) call stats % set ( 'mx' , s ( 2 , 1 )) call stats % set ( 'sx' , s ( 3 , 1 )) call stats % set ( 'lqx' , s ( 4 , 1 )) call stats % set ( 'uqx' , s ( 5 , 1 )) if ( seq_is_x ) then write ( 6 , 10 ) ' count n -> ' , n_seq call print_value ( ' mean ux -> ' , s ( 1 , 1 )) call print_value ( ' stddev sx -> ' , s ( 3 , 1 )) call print_value ( ' median mx -> ' , s ( 2 , 1 )) call print_value ( 'lower_q lqx -> ' , s ( 4 , 1 )) call print_value ( 'upper_q uqx -> ' , s ( 5 , 1 )) else call summary_stats ( y_seq ( 1 : n_seq ), s ( 1 , 2 ), s ( 2 , 2 ), s ( 3 , 2 ), s ( 4 , 2 ), s ( 5 , 2 )) write ( 6 , 10 ) ' count n -> ' , n_seq call print_value ( ' means ux , uy -> ' , s ( 1 , 1 ), s ( 1 , 2 )) call print_value ( ' stddevs sx , xy -> ' , s ( 3 , 1 ), s ( 3 , 2 )) call print_value ( ' medians mx , my -> ' , s ( 2 , 1 ), s ( 2 , 2 )) call print_value ( 'lower_qs lqx , lqy -> ' , s ( 4 , 1 ), s ( 4 , 2 )) call print_value ( 'upper_qs uqx , uqy -> ' , s ( 5 , 1 ), s ( 5 , 2 )) call stats % set ( 'uy' , s ( 1 , 2 )) call stats % set ( 'my' , s ( 2 , 2 )) call stats % set ( 'sy' , s ( 3 , 2 )) call stats % set ( 'lqy' , s ( 4 , 2 )) call stats % set ( 'uqy' , s ( 5 , 2 )) call calculate_regression ( s ( 1 , 1 ), s ( 1 , 2 ), a , b , c , sxy ) call stats % set ( 'a' , a ) call stats % set ( 'b' , b ) call stats % set ( 'corr' , c ) call stats % set ( 'cov' , sxy ) write ( 6 , '(/a)' ) 'Regression: y = ax + b' call print_value ( ' gradient a ->' , a ) call print_value ( ' intercept b -> ' , b ) call print_value ( ' covariance cov -> ' , sxy ) call print_value ( 'correlation corr -> ' , c ) end if 10 format ( a , i0 ) end subroutine calculate_stats","tags":"","loc":"proc/calculate_stats.html"},{"title":"help – hp","text":"subroutine help() Arguments None Contents Source Code help Source Code subroutine help write ( 6 , '(/a)' ) 'Command Calculator' write ( 6 , '(a/)' ) '==================' write ( 6 , '(a)' ) 'Introduction' write ( 6 , '(a/)' ) '------------' write ( 6 , '(a)' ) 'This is a command-line calculator. It supports both real and complex modes, as well' write ( 6 , '(a)' ) 'as degrees/radians selection and precision control. It can be run interactively or as an' write ( 6 , '(a/)' ) 'expression parser. This help is deliberately terse to encourage exploration.' write ( 6 , '(a/)' ) '-------------------------------------------------------------------------------' write ( 6 , '(a)' ) 'Operators: + - * / ^ ^/x ^x ^2 ^/2 ^3 ^/3 ^*2 ^*10 || ! %' write ( 6 , '(a)' ) 'Constants: pi e g G c two_pi pi_over_2' write ( 6 , '(a)' ) 'Functions: sin cos tan asin acos atan sinh cosh tanh log2 log lg len sq sqrt cb cbrt' write ( 6 , '(a)' ) ' alog2 alog alog10 gamma ncr npr rem int nint' write ( 6 , '(a)' ) ' Controls: fix[0-9] clx cl cla ' write ( 6 , '(a)' ) ' Modes: real complex verbose terse degrees radians' write ( 6 , '(a)' ) ' Memories: n=0...9 st<n> sw<n> rc<n> cl<n> m<n>+ m<n>- m<n>* m<n>/ msh' write ( 6 , '(a)' ) ' Complex: ri _ || to_pol to_cart' write ( 6 , '(a)' ) ' Actions: 1/ -- R r ? > < split drop' write ( 6 , '(a)' ) ' Stats: { x1 x2 ... } { x1,y1 x2,y2 ... }' write ( 6 , '(a)' ) ' n ux sx mx lqx uqx uy sy my lqy uqy a b cov corr' write ( 6 , '(a/)' ) ' Quits: q' write ( 6 , '(a/)' ) '-------------------------------------------------------------------------------' write ( 6 , '(a)' ) 'Examples' write ( 6 , '(a)' ) '--------' write ( 6 , '(4x,a)' ) 'hp \"fix2 18 2 - 8 2 / * =\" -> 64.00' write ( 6 , '(4x,a)' ) 'hp \"2 -- complex sqrt =\" -> (0.00000,-1.414214)' write ( 6 , '(4x,a/)' ) 'hp -c \"radians (1,pi_over_2)p ^ * degrees =\" -> (1.000000,180.000000) p' end subroutine help","tags":"","loc":"proc/help.html"},{"title":"invoke_binary – hp","text":"subroutine invoke_binary(action) Arguments Type Intent Optional Attributes Name procedure( binary_f ), intent(in), pointer :: action Contents Variables is_cart us zs Source Code invoke_binary Variables Type Visibility Attributes Name Initial logical, public :: is_cart type( rpn_t ), public :: us type( rpn_t ), public :: zs Source Code subroutine invoke_binary ( action ) procedure ( binary_f ), pointer , intent ( in ) :: action type ( rpn_t ) :: us , zs logical :: is_cart zs = stack % pop () if ( complex_mode ) then is_cart = zs % is_cartesian () if (. not . is_cart ) then zs = to_cartesian ( zs ) end if us = stack % peek ( 1 ) if (. not . us % is_cartesian ()) then us = to_polar ( us ) end if us = action ( us , zs ) if (. not . is_cart ) then us = to_polar ( us ) end if call stack % set ( us ) else us = stack % peek ( 1 ) call stack % set ( action ( us , zs )) end if end subroutine invoke_binary","tags":"","loc":"proc/invoke_binary.html"},{"title":"invoke_unary – hp","text":"subroutine invoke_unary(action) Arguments Type Intent Optional Attributes Name procedure( unary_f ), intent(in), pointer :: action Contents Variables is_cart z Source Code invoke_unary Variables Type Visibility Attributes Name Initial logical, public :: is_cart type( rpn_t ), public :: z Source Code subroutine invoke_unary ( action ) procedure ( unary_f ), pointer , intent ( in ) :: action logical :: is_cart type ( rpn_t ) :: z if ( complex_mode ) then z = stack % peek ( 1 ) is_cart = z % is_cartesian () if (. not . is_cart ) then z = to_cartesian ( z ) end if z = action ( z ) if (. not . is_cart ) then z = to_polar ( z ) end if call stack % set ( z ) else call stack % set ( action ( stack % peek ( 1 ))) end if end subroutine invoke_unary","tags":"","loc":"proc/invoke_unary.html"},{"title":"print_value – hp","text":"subroutine print_value(name, x, y) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: name real(kind=8), intent(in) :: x real(kind=8), intent(in), optional :: y Contents Variables fmt_x fmt_y Source Code print_value Variables Type Visibility Attributes Name Initial character(len=:), public, allocatable :: fmt_x character(len=:), public, allocatable :: fmt_y Source Code subroutine print_value ( name , x , y ) character ( len =* ), intent ( in ) :: name real ( 8 ), intent ( in ) :: x real ( 8 ), intent ( in ), optional :: y character ( len = :), allocatable :: fmt_x , fmt_y call to_string ( x , fmt_x ) if ( present ( y )) then call to_string ( y , fmt_y ) fmt_x = fmt_x // ' , ' // fmt_y end if write ( 6 , '(a)' ) name // fmt_x end subroutine print_value","tags":"","loc":"proc/print_value.html"},{"title":"sort – hp","text":"subroutine sort(a) Arguments Type Intent Optional Attributes Name real(kind=8), intent(inout) :: a (:) Contents Variables b i j mask Variables Type Visibility Attributes Name Initial real(kind=8), public :: b (size(a)) integer, public :: i integer, public :: j (size(a)) logical, public :: mask (size(a))","tags":"","loc":"proc/sort.html"},{"title":"summary_stats – hp","text":"subroutine summary_stats(a, mean, median, stddev, lower_q, upper_q) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: a (:) real(kind=8), intent(out) :: mean real(kind=8), intent(out) :: median real(kind=8), intent(out) :: stddev real(kind=8), intent(out) :: lower_q real(kind=8), intent(out) :: upper_q Contents Variables b m n s s2 Source Code summary_stats Variables Type Visibility Attributes Name Initial real(kind=8), public :: b (size(a)) integer, public :: m integer, public :: n real(kind=8), public :: s real(kind=8), public :: s2 Source Code subroutine summary_stats ( a , mean , median , stddev , lower_q , upper_q ) real ( 8 ), intent ( in ) :: a (:) real ( 8 ), intent ( out ) :: mean , median , stddev , lower_q , upper_q real ( 8 ) :: b ( size ( a )) real ( 8 ) :: s , s2 integer :: m , n n = size ( a ) b = a s = sum ( b ) s2 = sum ( b ** 2 ) mean = s / n stddev = sqrt ( s2 / n - ( s / n ) ** 2 ) call sort ( b ) median = calc_median ( b , m ) if ( n < 3 ) then lower_q = median upper_q = median else lower_q = calc_median ( b ( 1 : m )) if ( mod ( n , 2 ) == 0 ) then upper_q = calc_median ( b ( m + 1 : n )) else upper_q = calc_median ( b ( m : n )) end if end if end subroutine summary_stats","tags":"","loc":"proc/summary_stats.html"},{"title":"toggle_degrees_mode – hp","text":"subroutine toggle_degrees_mode(new_mode) Arguments Type Intent Optional Attributes Name logical, intent(in) :: new_mode Contents Variables i rz Source Code toggle_degrees_mode Variables Type Visibility Attributes Name Initial integer, public :: i type( rpn_t ), public :: rz Source Code subroutine toggle_degrees_mode ( new_mode ) logical , intent ( in ) :: new_mode integer :: i type ( rpn_t ) :: rz ! Only do something if the modes are different if ( new_mode . eqv . degrees_mode ) return degrees_mode = . not . degrees_mode ! Convert all polar complex numbers ! 1) In the stack do i = 1 , stack % ssize rz = stack % peek ( i ) call update_angle_unit ( rz ) call stack % set ( rz , i ) end do ! 2) in memory do i = lbound ( mem , 1 ), ubound ( mem , 1 ) call update_angle_unit ( mem ( i )) end do ! 3) in multiple roots do i = 1 , nroots call update_angle_unit ( roots ( i )) end do end subroutine toggle_degrees_mode","tags":"","loc":"proc/toggle_degrees_mode.html"},{"title":"tokenize – hp","text":"subroutine tokenize(com) Arguments Type Intent Optional Attributes Name character, intent(in) :: com Contents Variables command end start Source Code tokenize Variables Type Visibility Attributes Name Initial character(len=:), public, allocatable :: command integer, public :: end integer, public :: start Source Code subroutine tokenize ( com ) character ( * ), intent ( in ) :: com integer :: start , end character ( len = :), allocatable :: command call clear_ll ( tokens ) if ( len_trim ( com ) == 0 ) then return end if start = 1 ! Ensure there are no leading and trailing spaces command = trim ( adjustl ( com )) end = index ( command , ' ' ) end = merge ( len ( command ), end - 1 , end == 0 ) do call append ( tokens , command ( start : end )) if ( end == len ( command )) exit start = end + nsp ( command ( end + 1 :)) end = index ( command ( start :), ' ' ) - 1 end = merge ( len ( command ), end + start - 1 , end == - 1 ) end do end subroutine tokenize","tags":"","loc":"proc/tokenize.html"},{"title":"update_angle_unit – hp","text":"subroutine update_angle_unit(rz) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(inout) :: rz Contents Variables is_cart zs Source Code update_angle_unit Variables Type Visibility Attributes Name Initial logical, public :: is_cart complex(kind=8), public :: zs Source Code subroutine update_angle_unit ( rz ) type ( rpn_t ), intent ( inout ) :: rz complex ( 8 ) :: zs logical :: is_cart zs = rz % get_value ( is_cart ) if ( is_cart ) return zs % im = zs % im * merge ( to_deg , to_rad , degrees_mode ) call rz % set_value ( zs , is_cart ) end subroutine update_angle_unit","tags":"","loc":"proc/update_angle_unit.html"},{"title":"rpn_stack – hp","text":"Used by Descendants: rpn_sm stack_sm Contents Variables complex_mode dec_places degrees_mode eps nroots pi roots to_deg to_rad Interfaces acosine_fr add_fr add_rpns ahcosine_fr ahsine_fr ahtangent_fr asine_fr atangent2_fr atangent_fr cbrt_fr chs_fr clear_stackt conj_fr cosine_fr divide_fr divide_rpns exp_10_fr exp_2_fr exp_e_fr fact_fr gamma_fr get_places get_size_stackt get_value_rpns hcosine_fr hsine_fr htangent_fr init is_cartesian_rpns is_integer_rpns is_positive_real_rpns is_real_rpns len_fr lg_fr ln_fr log2_fr multiply_fr multiply_rpns ncr_fr next_root_fr npr_fr peek_stackt percent_fr pop_stackt power_2_fr power_3_fr power_fr power_rpns previous_root_fr print_stackt push_all_stackt push_r_stackt push_stackt reciprocal_fr root_fr rotate_down_stackt rotate_up_stackt round set_angle_unit_rpns set_legend_stackt set_places set_stackt set_to_rpns set_value_rpns sine_fr sqrt_fr subtract_fr subtract_rpns swap_real_imaginary_fr swap_stackt tangent_fr to_cartesian to_polar to_string write_rpns Abstract Interfaces binary_f unary_f Derived Types rpn_t stack_t Variables Type Visibility Attributes Name Initial logical, public :: complex_mode = .false. integer, public :: dec_places = 6 logical, public :: degrees_mode = .true. real(kind=8), public :: eps = 1.0d-14 integer, public :: nroots = 0 real(kind=8), public, parameter :: pi = 4*atan(1.0d0) type( rpn_t ), public, allocatable :: roots (:) real(kind=8), public, parameter :: to_deg = 180/pi real(kind=8), public, parameter :: to_rad = pi/180 Interfaces interface public module function acosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function add_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function add_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function ahcosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function ahsine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function ahtangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function asine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function atangent2_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function atangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function cbrt_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function chs_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module subroutine clear_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk interface public module function conj_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function cosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function divide_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function divide_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function exp_10_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function exp_2_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function exp_e_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function fact_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function gamma_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function get_places() result(r) Arguments None Return Value integer interface public module function get_size_stackt(stk) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(in) :: stk Return Value integer interface public module function get_value_rpns(this, is_cartesian) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this logical, intent(out), optional :: is_cartesian Return Value complex(kind=8) interface public module function hcosine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function hsine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function htangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module subroutine init(lang) Arguments Type Intent Optional Attributes Name character(len=5), intent(in), optional :: lang interface public module function is_cartesian_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical interface public module function is_integer_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical interface public module function is_positive_real_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical interface public module function is_real_rpns(this) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this Return Value logical interface public module function len_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function lg_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function ln_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function log2_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function multiply_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function multiply_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function ncr_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function next_root_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function npr_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function peek_stackt(stk, idx) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk integer, intent(in) :: idx Return Value type( rpn_t ) interface public module function percent_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function pop_stackt(stk) result(r) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk Return Value type( rpn_t ) interface public module function power_2_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function power_3_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function power_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function power_rpns(this, x) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: this real(kind=8), intent(in) :: x Return Value type( rpn_t ) interface public module function previous_root_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module subroutine print_stackt(stk, ve_mode) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(in) :: stk logical, intent(in) :: ve_mode interface public module subroutine push_all_stackt(stk, z, is_cart) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk complex(kind=8), intent(in) :: z logical, intent(in), optional :: is_cart interface public module subroutine push_r_stackt(stk, x) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk real(kind=8) :: x interface public module subroutine push_stackt(stk, z) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk type( rpn_t ) :: z interface public module function reciprocal_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function root_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module subroutine rotate_down_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk interface public module subroutine rotate_up_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk interface public module function round(x) result(r) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: x Return Value real(kind=8) interface public module subroutine set_angle_unit_rpns(this, degrees) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this logical, intent(in) :: degrees interface public module subroutine set_legend_stackt(stk, legend) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk character(len=2), intent(in) :: legend (:) interface public module subroutine set_places(n) Arguments Type Intent Optional Attributes Name integer, intent(in) :: n interface public module subroutine set_stackt(stk, z, idx) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk type( rpn_t ), intent(in) :: z integer, intent(in), optional :: idx interface public module subroutine set_to_rpns(this, z) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this type( rpn_t ), intent(in) :: z interface public module subroutine set_value_rpns(this, z, is_cartesian) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(inout) :: this complex(kind=8), intent(in), optional :: z logical, intent(in), optional :: is_cartesian interface public module function sine_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function sqrt_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module function subtract_fr(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function subtract_rpns(a, b) result(r) Arguments Type Intent Optional Attributes Name class( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) interface public module function swap_real_imaginary_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) interface public module subroutine swap_stackt(stk) Arguments Type Intent Optional Attributes Name class( stack_t (*)), intent(inout) :: stk interface public module function tangent_fr(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) public interface to_cartesian public module function to_cartesian_rpns(stk_z) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: stk_z Return Value type( rpn_t ) public interface to_polar public module function to_polar_rpns(stk_z) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: stk_z Return Value type( rpn_t ) interface public module subroutine to_string(x, str) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: x character(len=:), intent(out), allocatable :: str interface public module subroutine write_rpns(se, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name 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 Abstract Interfaces abstract interface public function binary_f(a, b) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a type( rpn_t ), intent(in) :: b Return Value type( rpn_t ) abstract interface public function unary_f(a) result(r) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(in) :: a Return Value type( rpn_t ) Derived Types type, public :: rpn_t Type-Bound Procedures generic,\n public\n :: assignment(=) =>\n set_to_rpns procedure\n , public\n :: get_value => get_value_rpns Interface procedure\n , public\n :: is_cartesian => is_cartesian_rpns Interface procedure\n , public\n :: is_integer => is_integer_rpns Interface procedure\n , public\n :: is_positive_real => is_positive_real_rpns Interface procedure\n , public\n :: is_real => is_real_rpns Interface generic,\n public\n :: operator(*) =>\n multiply_rpns generic,\n public\n :: operator(**) =>\n power_rpns generic,\n public\n :: operator(+) =>\n add_rpns generic,\n public\n :: operator(-) =>\n subtract_rpns generic,\n public\n :: operator(/) =>\n divide_rpns procedure\n , public\n :: set_angle_unit => set_angle_unit_rpns Interface procedure\n , public\n :: set_value => set_value_rpns Interface generic,\n public\n :: write(formatted) =>\n write_rpns type, public :: stack_t Components Type Visibility Attributes Name Initial integer, public, len :: ssize Type-Bound Procedures procedure\n , public\n :: clear => clear_stackt Interface procedure\n , public\n :: get_size => get_size_stackt Interface procedure\n , public\n :: peek => peek_stackt Interface procedure\n , public\n :: pop => pop_stackt Interface procedure\n , public\n :: print => print_stackt Interface generic,\n public\n :: push =>\n push_stackt, push_all_stackt, push_r_stackt procedure\n , public\n :: rotate_down => rotate_down_stackt Interface procedure\n , public\n :: rotate_up => rotate_up_stackt Interface procedure\n , public\n :: set => set_stackt Interface procedure\n , public\n :: set_legend => set_legend_stackt Interface procedure\n , public\n :: swap => swap_stackt Interface","tags":"","loc":"module/rpn_stack.html"},{"title":"linked_list – hp","text":"Contents Abstract Interfaces command_fun Derived Types llist llist_node Functions iterate_ll size Subroutines append clear print Abstract Interfaces abstract interface public subroutine command_fun(command, ok) Arguments Type Intent Optional Attributes Name character, intent(in) :: command logical, intent(out) :: ok Derived Types type, public :: llist Type-Bound Procedures procedure\n , public\n :: iterate => iterate_ll Function type, public :: llist_node Functions public function iterate_ll (this, f) result(r) Arguments Type Intent Optional Attributes Name class( llist ), intent(inout), target :: this procedure( command_fun ) :: f Return Value logical public function size (lst) Arguments Type Intent Optional Attributes Name type( llist ), intent(inout) :: lst Return Value integer Subroutines public subroutine append (lst, data) Arguments Type Intent Optional Attributes Name type( llist ), intent(inout) :: lst character, intent(in) :: data public subroutine clear (lst) Arguments Type Intent Optional Attributes Name type( llist ), intent(inout) :: lst public subroutine print (lst) Arguments Type Intent Optional Attributes Name type( llist ), intent(in) :: lst","tags":"","loc":"module/linked_list.html"},{"title":"amap – hp","text":"Contents Derived Types amap_t key_t pair_t value_t Functions equals_key_t find_amap_t get_amap_t get_value_amap_t is_key_kt is_key_kvt Subroutines clear_amap_t print_amap_t set_amap_t set_to_key_t set_to_value_t write_key_t write_value_t Derived Types type, public :: amap_t Type-Bound Procedures procedure\n , public\n :: clear => clear_amap_t Subroutine generic,\n public\n :: contains =>\n is_key_kt, is_key_kvt procedure\n , public\n :: find => find_amap_t Function procedure\n , public\n :: get => get_amap_t Function procedure\n , public\n :: get_value => get_value_amap_t Function procedure\n , public\n :: print => print_amap_t Subroutine procedure\n , public\n :: set => set_amap_t Subroutine type, public :: key_t Type-Bound Procedures generic,\n public\n :: assignment(=) =>\n set_to_key_t generic,\n public\n :: operator(==) =>\n equals_key_t generic,\n public\n :: write(formatted) =>\n write_key_t type, public :: pair_t Components Type Visibility Attributes Name Initial type( key_t ), public :: k = key_t() type( value_t ), public :: v = value_t() type, public :: value_t Type-Bound Procedures generic,\n public\n :: assignment(=) =>\n set_to_value_t generic,\n public\n :: write(formatted) =>\n write_value_t Functions public function equals_key_t (this, k) result(r) Arguments Type Intent Optional Attributes Name class( key_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value logical public function find_amap_t (this, k) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value integer public function get_amap_t (this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value type( value_t ) public function get_value_amap_t (this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value real(kind=8) public function is_key_kt (this, k) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this type( key_t ), intent(in) :: k Return Value logical public function is_key_kvt (this, kv) result(r) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this character(len=*), intent(in) :: kv Return Value logical Subroutines public subroutine clear_amap_t (this) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(inout) :: this public subroutine print_amap_t (this) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(in) :: this public subroutine set_amap_t (this, kv, vv) Arguments Type Intent Optional Attributes Name class( amap_t ), intent(inout) :: this character(len=*), intent(in) :: kv real(kind=8), intent(in) :: vv public subroutine set_to_key_t (this, k) Arguments Type Intent Optional Attributes Name class( key_t ), intent(inout) :: this character(len=*), intent(in) :: k public subroutine set_to_value_t (this, v) Arguments Type Intent Optional Attributes Name class( value_t ), intent(inout) :: this real(kind=8), intent(in) :: v public subroutine write_key_t (key, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name class( key_t ), intent(in) :: key integer, intent(in) :: unit character, intent(in) :: iotype integer, intent(in) :: v_list (:) integer, intent(out) :: iostat character, intent(inout) :: iomsg public subroutine write_value_t (value, unit, iotype, v_list, iostat, iomsg) Arguments Type Intent Optional Attributes Name class( value_t ), intent(in) :: value integer, intent(in) :: unit character, intent(in) :: iotype integer, intent(in) :: v_list (:) integer, intent(out) :: iostat character, intent(inout) :: iomsg","tags":"","loc":"module/amap.html"},{"title":"stack_sm – hp","text":"Uses Ancestors: rpn_stack Contents None","tags":"","loc":"module/stack_sm.html"},{"title":"rpn_sm – hp","text":"Uses Ancestors: rpn_stack Contents None","tags":"","loc":"module/rpn_sm.html"},{"title":"hp15c – hp","text":"Uses linked_list amap rpn_stack Contents Variables ag argc argl blen buff c constants e g getNext have_expression i in_sequence ios lang lang_en mem msg n_seq numbers ok seq_is_x stack stat stats tmp_cmode token tokens veMode verbosity x x_seq y_seq Functions calc_median nsp Subroutines apply_command calculate_regression calculate_stats help invoke_binary invoke_unary print_value sort summary_stats toggle_degrees_mode tokenize update_angle_unit Source Code hp15c Variables Type Attributes Name Initial real(kind=8), parameter :: ag = 9.80665d0 integer :: argc integer :: argl integer :: blen character(len=100) :: buff real(kind=8), parameter :: c = 2.99792458d8 type( amap_t ) :: constants real(kind=8), parameter :: e = exp(1.0d0) real(kind=8), parameter :: g = 6.67430d-11 logical :: getNext logical :: have_expression integer :: i integer :: in_sequence = 0 integer :: ios character(len=5) :: lang logical :: lang_en = .true. type( rpn_t ) :: mem (0:9) = rpn_t() character(len=100) :: msg integer :: n_seq = 0 logical :: numbers logical :: ok logical :: seq_is_x type( stack_t (5)) :: stack integer :: stat type( amap_t ) :: stats logical :: tmp_cmode type( llist_node ), pointer :: token type( llist ) :: tokens logical :: veMode = .false. integer :: verbosity = 0 real(kind=8) :: x real(kind=8), allocatable :: x_seq (:) real(kind=8), allocatable :: y_seq (:) Functions function calc_median (a, mid) result(r) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: a (:) integer, intent(out), optional :: mid Return Value real(kind=8) function nsp (command) Arguments Type Intent Optional Attributes Name character, intent(in) :: command Return Value integer Subroutines subroutine apply_command (command, ok) Arguments Type Intent Optional Attributes Name character, intent(in) :: command logical, intent(out) :: ok subroutine calculate_regression (mean_x, mean_y, a, b, c, sxy) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: mean_x real(kind=8), intent(in) :: mean_y real(kind=8), intent(out) :: a real(kind=8), intent(out) :: b real(kind=8), intent(out) :: c real(kind=8), intent(out) :: sxy subroutine calculate_stats () Arguments None subroutine help () Arguments None subroutine invoke_binary (action) Arguments Type Intent Optional Attributes Name procedure( binary_f ), intent(in), pointer :: action subroutine invoke_unary (action) Arguments Type Intent Optional Attributes Name procedure( unary_f ), intent(in), pointer :: action subroutine print_value (name, x, y) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: name real(kind=8), intent(in) :: x real(kind=8), intent(in), optional :: y subroutine sort (a) Arguments Type Intent Optional Attributes Name real(kind=8), intent(inout) :: a (:) subroutine summary_stats (a, mean, median, stddev, lower_q, upper_q) Arguments Type Intent Optional Attributes Name real(kind=8), intent(in) :: a (:) real(kind=8), intent(out) :: mean real(kind=8), intent(out) :: median real(kind=8), intent(out) :: stddev real(kind=8), intent(out) :: lower_q real(kind=8), intent(out) :: upper_q subroutine toggle_degrees_mode (new_mode) Arguments Type Intent Optional Attributes Name logical, intent(in) :: new_mode subroutine tokenize (com) Arguments Type Intent Optional Attributes Name character, intent(in) :: com subroutine update_angle_unit (rz) Arguments Type Intent Optional Attributes Name type( rpn_t ), intent(inout) :: rz Source Code program hp15c use rpn_stack use linked_list , print_ll => print , clear_ll => clear , size_ll => size use amap implicit none real ( 8 ) :: x integer :: ios , i integer :: verbosity = 0 character ( 100 ) :: buff integer :: blen integer :: argl , argc type ( llist ) :: tokens type ( llist_node ), pointer :: token real ( 8 ), parameter :: ag = 9.80665d0 real ( 8 ), parameter :: g = 6.67430d-11 real ( 8 ), parameter :: e = exp ( 1.0d0 ) real ( 8 ), parameter :: c = 2.99792458d8 type ( amap_t ) :: constants type ( amap_t ) :: stats integer :: in_sequence = 0 logical :: seq_is_x real ( 8 ), allocatable :: x_seq (:), y_seq (:) integer :: n_seq = 0 logical :: veMode = . false . logical :: lang_en = . true . logical :: tmp_cmode logical :: ok logical :: getNext , numbers , have_expression integer :: stat character ( len = 100 ) :: msg character ( 5 ) :: lang type ( rpn_t ) :: mem ( 0 : 9 ) = rpn_t () ! Create a stack of size 4 type ( stack_t ( 5 )) :: stack call stack % set_legend ([ 'x:' , 'y:' , 'z:' , 's' , 't:' ]) degrees_mode = . true . complex_mode = . false . eps = 1.0d-14 ! Constants call constants % set ( 'g' , ag ) call constants % set ( 'G' , g ) call constants % set ( 'e' , e ) call constants % set ( 'c' , c ) call constants % set ( 'pi' , pi ) call constants % set ( 'two_pi' , 2 * pi ) call constants % set ( 'pi_over_2' , pi / 2 ) ! Try to read the LANG environment variable call get_environment_variable ( 'LANG' , lang , status = stat ) lang_en = stat /= 0 if (. not . lang_en ) then lang_en = merge (. true .,. false ., lang ( 1 : 3 ) == 'en_' ) end if lang = merge ( 'POINT' , 'COMMA' , lang_en ) call init ( lang ) ! Interrogate argument list argc = command_argument_count () have_expression = . false . do i = 1 , argc call get_command_argument ( i , buff , argl ) if ( buff ( 1 : argl ) == '-d' ) then verbosity = 1 cycle else if ( buff ( 1 : argl ) == '-c' ) then complex_mode = . true . cycle else if ( buff ( 1 : argl ) == '-v' ) then veMode = . true . cycle else if ( buff ( 1 : argl ) == '-h' ) then call help stop end if have_expression = . true . ! Break the string up into a linked-list of tokens call tokenize ( buff ( 1 : argl )) if ( verbosity > 0 ) call print_ll ( tokens ) ! Interpret each token as a command and appky it ok = tokens % iterate ( apply_command ) ! Do not print the stack at the end of a sequence -it's confusing if ( in_sequence /= 2 ) then call stack % print ( veMode ) end if ! Tidy call clear_ll ( tokens ) if (. not . ok ) stop end do if (. not . have_expression ) then call stack % print ( veMode ) end if ! Loop until quit all : do x = 0.0d0 buff = '' write ( 6 , '(a)' , advance = 'no' ) ':: ' read ( 5 , fmt = '(a)' , iostat = ios , iomsg = msg ) buff if ( ios /= 0 ) then write ( 6 , '(/a)' ) 'Command:[' // buff ( 1 : blen ) // ']' // '; ' // msg cycle all end if buff = trim ( adjustl ( buff )) blen = len_trim ( buff ) if ( blen == 0 ) cycle all ! Tokenize input string call tokenize ( buff ( 1 : blen )) ok = tokens % iterate ( apply_command ) if (. not . ok ) exit all if ( in_sequence == 1 ) then write ( 6 , '(i0)' ) n_seq else if ( in_sequence == 2 ) then in_sequence = 0 else call stack % print ( veMode ) end if end do all call clear_ll ( tokens ) stop contains subroutine tokenize ( com ) character ( * ), intent ( in ) :: com integer :: start , end character ( len = :), allocatable :: command call clear_ll ( tokens ) if ( len_trim ( com ) == 0 ) then return end if start = 1 ! Ensure there are no leading and trailing spaces command = trim ( adjustl ( com )) end = index ( command , ' ' ) end = merge ( len ( command ), end - 1 , end == 0 ) do call append ( tokens , command ( start : end )) if ( end == len ( command )) exit start = end + nsp ( command ( end + 1 :)) end = index ( command ( start :), ' ' ) - 1 end = merge ( len ( command ), end + start - 1 , end == - 1 ) end do end subroutine tokenize subroutine help write ( 6 , '(/a)' ) 'Command Calculator' write ( 6 , '(a/)' ) '==================' write ( 6 , '(a)' ) 'Introduction' write ( 6 , '(a/)' ) '------------' write ( 6 , '(a)' ) 'This is a command-line calculator. It supports both real and complex modes, as well' write ( 6 , '(a)' ) 'as degrees/radians selection and precision control. It can be run interactively or as an' write ( 6 , '(a/)' ) 'expression parser. This help is deliberately terse to encourage exploration.' write ( 6 , '(a/)' ) '-------------------------------------------------------------------------------' write ( 6 , '(a)' ) 'Operators: + - * / ^ ^/x ^x ^2 ^/2 ^3 ^/3 ^*2 ^*10 || ! %' write ( 6 , '(a)' ) 'Constants: pi e g G c two_pi pi_over_2' write ( 6 , '(a)' ) 'Functions: sin cos tan asin acos atan sinh cosh tanh log2 log lg len sq sqrt cb cbrt' write ( 6 , '(a)' ) ' alog2 alog alog10 gamma ncr npr rem int nint' write ( 6 , '(a)' ) ' Controls: fix[0-9] clx cl cla ' write ( 6 , '(a)' ) ' Modes: real complex verbose terse degrees radians' write ( 6 , '(a)' ) ' Memories: n=0...9 st<n> sw<n> rc<n> cl<n> m<n>+ m<n>- m<n>* m<n>/ msh' write ( 6 , '(a)' ) ' Complex: ri _ || to_pol to_cart' write ( 6 , '(a)' ) ' Actions: 1/ -- R r ? > < split drop' write ( 6 , '(a)' ) ' Stats: { x1 x2 ... } { x1,y1 x2,y2 ... }' write ( 6 , '(a)' ) ' n ux sx mx lqx uqx uy sy my lqy uqy a b cov corr' write ( 6 , '(a/)' ) ' Quits: q' write ( 6 , '(a/)' ) '-------------------------------------------------------------------------------' write ( 6 , '(a)' ) 'Examples' write ( 6 , '(a)' ) '--------' write ( 6 , '(4x,a)' ) 'hp \"fix2 18 2 - 8 2 / * =\" -> 64.00' write ( 6 , '(4x,a)' ) 'hp \"2 -- complex sqrt =\" -> (0.00000,-1.414214)' write ( 6 , '(4x,a/)' ) 'hp -c \"radians (1,pi_over_2)p ^ * degrees =\" -> (1.000000,180.000000) p' end subroutine help subroutine apply_command ( command , ok ) use , intrinsic :: ieee_arithmetic implicit none character ( * ), intent ( in ) :: command logical , intent ( out ) :: ok real ( 8 ) :: r , im , ang complex ( 8 ) :: u , z real ( 8 ), allocatable :: tmp_seq (:) type ( rpn_t ) :: us , zs logical :: is_cart integer :: m , idx character ( len = 1 ) :: comma character ( 5 ), parameter :: lang ( 2 ) = [ 'POINT' , 'COMMA' ] ok = . true . if ( len_trim ( command ) == 0 ) then return end if if ( verbosity > 0 ) then write ( * , '(a)' ) 'Applying: ' // command end if if ( in_sequence == 1 ) then if ( command == '}' ) then in_sequence = 2 complex_mode = tmp_cmode call calculate_stats else ! All elements must be the same so either all x or all x,y idx = index ( command , ',' ) if ( n_seq == 0 ) then seq_is_x = ( idx == 0 ) end if if ( seq_is_x . neqv . ( idx == 0 )) then goto 901 end if if ( seq_is_x ) then read ( command , * , err = 901 ) r im = 0 else read ( command ( 1 : idx - 1 ), * , err = 901 ) r read ( command ( idx + 1 : len ( command )), * , err = 901 ) im end if ! Initial allocation if ( n_seq == 0 . and . . not . allocated ( x_seq )) then allocate ( x_seq ( 10 )) if (. not . seq_is_x ) then allocate ( y_seq ( 10 )) end if end if if ( n_seq < size ( x_seq )) then n_seq = n_seq + 1 else ! Expand array allocate ( tmp_seq ( n_seq + 10 )) tmp_seq ( 1 : n_seq ) = x_seq call move_alloc ( tmp_seq , x_seq ) if (. not . seq_is_x ) then allocate ( tmp_seq ( n_seq + 10 )) tmp_seq ( 1 : n_seq ) = y_seq call move_alloc ( tmp_seq , y_seq ) end if end if x_seq ( n_seq ) = r if (. not . seq_is_x ) then y_seq ( n_seq ) = im end if if ( verbosity > 0 ) then print * , x_seq ( 1 : n_seq ) end if end if return end if select case ( command ) case ( 'q' , 'quit' ) ok = . false . return case ( '=' ) ok = . false . return case ( '{' ) ! Start sequence in_sequence = 1 n_seq = 0 tmp_cmode = complex_mode complex_mode = . false . call stats % clear () case ( '--' ) call invoke_unary ( chs_fr ) case ( '^' ) call stack % push ( stack % peek ( 1 )) case ( '+' ) call invoke_binary ( add_fr ) case ( '-' ) call invoke_binary ( subtract_fr ) case ( '*' ) call invoke_binary ( multiply_fr ) case ( '/' ) call invoke_binary ( divide_fr ) case ( '^x' ) call invoke_binary ( power_fr ) case ( '^/x' ) ! Only raising to a real power is supported zs = stack % peek ( 1 ) if ( zs % is_real ()) then call invoke_binary ( root_fr ) else goto 901 end if case ( '>' ) call invoke_unary ( next_root_fr ) case ( '<' ) call invoke_unary ( previous_root_fr ) case ( '%' ) call invoke_binary ( percent_fr ) case ( 'xy' , 'XY' ) call stack % swap case ( 'R' ) call stack % rotate_down case ( 'r' ) call stack % rotate_up case ( 'CLA' , 'cla' ) call stack % clear mem = rpn_t () call stats % clear case ( 'CL' , 'cl' ) call stack % clear case ( 'CLX' , 'clx' ) call stack % set ( rpn_t ()) case ( '_' ) if ( complex_mode ) then call invoke_unary ( conj_fr ) endif case ( 'len' , '||' ) if ( complex_mode ) then call invoke_unary ( len_fr ) ! Length is always reported as (x,0) and marked is_cartesian zs = stack % peek ( 1 ) call zs % set_value ( is_cartesian = . true .) call stack % set ( zs , 1 ) else zs = stack % peek ( 1 ) z = zs % get_value () us = stack % peek ( 2 ) u = us % get_value () call zs % set_value ( cmplx ( hypot ( z % re , u % re ), 0 , 8 )) call stack % set ( zs ) end if case ( 'split' ) if (. not . complex_mode ) then zs = stack % pop () x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if im = x - r call stack % push ( im ) call stack % push ( r ) end if case ( 'int' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if call zs % set_value ( cmplx ( r , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'nint' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () r = nint ( x ) if ( mod ( r , 2.0d0 ) == 1 ) then r = r - 1 end if call zs % set_value ( cmplx ( r , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'rem' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if im = x - r call zs % set_value ( cmplx ( im , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'drop' ) zs = stack % pop () case ( 'ri' ) ! Swap real and imaginary parts if ( complex_mode ) then call invoke_unary ( swap_real_imaginary_fr ) end if case ( 'to_pol' ) ! Convert x + iy to r + i theta if ( complex_mode ) then zs = stack % peek ( 1 ) call stack % set ( to_polar ( zs )) end if case ( 'to_cart' ) ! Convert (r,theta) to (x,y) if ( complex_mode ) then zs = stack % peek ( 1 ) call stack % set ( to_cartesian ( zs )) end if case ( '1/' ) call invoke_unary ( reciprocal_fr ) case ( '^2' , 'sq' ) call invoke_unary ( power_2_fr ) case ( '^/2' , 'sqrt' ) call invoke_unary ( sqrt_fr ) case ( '^3' , 'cb' ) call invoke_unary ( power_3_fr ) case ( '^/3' , 'cbrt' ) call invoke_unary ( cbrt_fr ) case ( '^*2' , 'alog2' ) call invoke_unary ( exp_2_fr ) case ( '^*10' , 'alog10' ) call invoke_unary ( exp_10_fr ) case ( 'exp' , 'alog' ) call invoke_unary ( exp_e_fr ) case ( 'ln' ) call invoke_unary ( ln_fr ) case ( 'log2' ) call invoke_unary ( log2_fr ) case ( 'lg' ) call invoke_unary ( lg_fr ) case ( 'sinh' ) call invoke_unary ( hsine_fr ) case ( 'cosh' ) call invoke_unary ( hcosine_fr ) case ( 'tanh' ) call invoke_unary ( htangent_fr ) case ( 'sin' ) call invoke_unary ( sine_fr ) case ( 'cos' ) call invoke_unary ( cosine_fr ) case ( 'tan' ) call invoke_unary ( tangent_fr ) case ( 'asin' ) call invoke_unary ( asine_fr ) case ( 'asinh' ) call invoke_unary ( ahsine_fr ) case ( 'acos' ) call invoke_unary ( acosine_fr ) case ( 'acosh' ) call invoke_unary ( ahcosine_fr ) case ( 'atan' ) call invoke_unary ( atangent_fr ) case ( 'atanh' ) call invoke_unary ( ahtangent_fr ) case ( 'atan2' ) call invoke_binary ( atangent2_fr ) case ( 'gamma' ) call invoke_unary ( gamma_fr ) case ( '!' ) zs = stack % peek ( 1 ) if ( zs % is_positive_real ()) then call invoke_unary ( fact_fr ) else goto 901 end if case ( 'ncr' ) zs = stack % peek ( 1 ) us = stack % peek ( 2 ) if ( zs % is_positive_real () . and . us % is_positive_real ()) then call invoke_binary ( ncr_fr ) else goto 901 end if case ( 'npr' ) zs = stack % peek ( 1 ) us = stack % peek ( 2 ) if ( zs % is_positive_real () . and . us % is_positive_real ()) then call invoke_binary ( npr_fr ) else goto 901 end if case ( 'm0+' , 'm1+' , 'm2+' , 'm3+' , 'm4+' , 'm5+' , 'm6+' , 'm7+' , 'm8+' , 'm9+' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) + stack % peek ( 1 ) case ( 'm0-' , 'm1-' , 'm2-' , 'm3-' , 'm4-' , 'm5-' , 'm6-' , 'm7-' , 'm8-' , 'm9-' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) - stack % peek ( 1 ) case ( 'm0*' , 'm1*' , 'm2*' , 'm3*' , 'm4*' , 'm5*' , 'm6*' , 'm7*' , 'm8*' , 'm9*' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) * stack % peek ( 1 ) case ( 'm0/' , 'm1/' , 'm2/' , 'm3/' , 'm4/' , 'm5/' , 'm6/' , 'm7/' , 'm8/' , 'm9/' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) / stack % peek ( 1 ) case ( 'st0' , 'st1' , 'st2' , 'st3' , 'st4' , 'st5' , 'st6' , 'st7' , 'st8' , 'st9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m mem ( m ) = stack % peek ( 1 ) case ( 'sw0' , 'sw1' , 'sw2' , 'sw3' , 'sw4' , 'sw5' , 'sw6' , 'sw7' , 'sw8' , 'sw9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m zs = stack % peek ( 1 ) call stack % set ( mem ( m )) mem ( m ) = zs case ( 'rc0' , 'rc1' , 'rc2' , 'rc3' , 'rc4' , 'rc5' , 'rc6' , 'rc7' , 'rc8' , 'rc9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m call stack % push ( mem ( m )) case ( 'cl0' , 'cl1' , 'cl2' , 'cl3' , 'cl4' , 'cl5' , 'cl6' , 'cl7' , 'cl8' , 'cl9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m mem ( m ) = rpn_t () case ( 'msh' ) write ( 6 , '(i3,a,dt)' ) ( i , ': ' , mem ( i ), i = 0 , size ( mem ) - 1 ) case ( 'fix0' , 'fix1' , 'fix2' , 'fix3' , 'fix4' , 'fix5' , 'fix6' , 'fix7' , 'fix8' , 'fix9' ) read ( command ( 4 : 4 ), '(i1)' ) m call set_places ( m ) case ( 'DEG' , 'deg' , 'DEGREES' , 'degrees' ) call toggle_degrees_mode (. true .) case ( 'RAD' , 'rad' , 'RADIANS' , 'radians' ) call toggle_degrees_mode (. false .) case ( 'mC' , 'COMPLEX' , 'complex' ) complex_mode = . true . case ( 'mR' , 'REAL' , 'real' ) complex_mode = . false . case ( 'mV' , 'VERBOSE' , 'verbose' ) veMode = . true . case ( 'mT' , 'TERSE' , 'terse' ) veMode = . false . case ( '?' ) write ( 6 , advance = 'no' , fmt = '(a)' ) 'Status: ' write ( 6 , advance = 'no' , fmt = '(2a)' ) merge ( 'degrees' , 'radians' , degrees_mode ), ' ; ' write ( 6 , advance = 'no' , fmt = '(a,i0)' ) 'dp = ' , get_places () if ( complex_mode ) then write ( 6 , advance = 'no' , fmt = '(a)' ) ' ; mode = complex' else write ( 6 , advance = 'no' , fmt = '(a)' ) ' ; mode = real' end if write ( 6 , advance = 'no' , fmt = '(a,i0)' ) ' ; stack size = ' , stack % get_size () write ( 6 , '(a/)' ) '' case ( 'help' , 'h' ) call help case default ! Process constants first block integer :: lc , is_integer , split_idx , end_idx character ( len = :), allocatable :: re_comp , im_comp lc = len_trim ( command ) is_integer = ( index ( command , '.' ) == 0 ) if ( complex_mode ) then if ( command ( 1 : 1 ) == '(' ) then split_idx = index ( command , ',' ) end_idx = index ( command , ')' ) re_comp = command ( 2 : split_idx - 1 ) im_comp = command ( split_idx + 1 : end_idx - 1 ) if ( constants % contains ( re_comp )) then z % re = constants % get_value ( re_comp ) else read ( re_comp , * , err = 901 , end = 901 ) z % re end if if ( constants % contains ( im_comp )) then z % im = constants % get_value ( im_comp ) else read ( im_comp , * , err = 901 , end = 901 ) z % im end if if ( command ( lc : lc ) == 'p' ) then call stack % push ( z ,. false .) else call stack % push ( z ) end if else if ( constants % contains ( command )) then x = constants % get_value ( command ) else read ( command , * , err = 901 , end = 901 ) x end if call stack % push ( cmplx ( x , 0.0d0 , 8 )) end if else if ( constants % contains ( command )) then x = constants % get_value ( command ) else if ( stats % contains ( command )) then x = stats % get_value ( command ) else read ( command , * , err = 901 , end = 901 ) x end if call stack % push ( cmplx ( x , 0.0d0 , 8 )) end if end block end select return 901 continue write ( 6 , '(a)' ) command // ' ???' return end subroutine apply_command subroutine calculate_stats real ( 8 ) :: a , b , c , sxy real ( 8 ) :: s ( 5 , 2 ) call summary_stats ( x_seq ( 1 : n_seq ), s ( 1 , 1 ), s ( 2 , 1 ), s ( 3 , 1 ), s ( 4 , 1 ), s ( 5 , 1 )) call stats % set ( 'n' , real ( n_seq , 8 )) call stats % set ( 'ux' , s ( 1 , 1 )) call stats % set ( 'mx' , s ( 2 , 1 )) call stats % set ( 'sx' , s ( 3 , 1 )) call stats % set ( 'lqx' , s ( 4 , 1 )) call stats % set ( 'uqx' , s ( 5 , 1 )) if ( seq_is_x ) then write ( 6 , 10 ) ' count n -> ' , n_seq call print_value ( ' mean ux -> ' , s ( 1 , 1 )) call print_value ( ' stddev sx -> ' , s ( 3 , 1 )) call print_value ( ' median mx -> ' , s ( 2 , 1 )) call print_value ( 'lower_q lqx -> ' , s ( 4 , 1 )) call print_value ( 'upper_q uqx -> ' , s ( 5 , 1 )) else call summary_stats ( y_seq ( 1 : n_seq ), s ( 1 , 2 ), s ( 2 , 2 ), s ( 3 , 2 ), s ( 4 , 2 ), s ( 5 , 2 )) write ( 6 , 10 ) ' count n -> ' , n_seq call print_value ( ' means ux , uy -> ' , s ( 1 , 1 ), s ( 1 , 2 )) call print_value ( ' stddevs sx , xy -> ' , s ( 3 , 1 ), s ( 3 , 2 )) call print_value ( ' medians mx , my -> ' , s ( 2 , 1 ), s ( 2 , 2 )) call print_value ( 'lower_qs lqx , lqy -> ' , s ( 4 , 1 ), s ( 4 , 2 )) call print_value ( 'upper_qs uqx , uqy -> ' , s ( 5 , 1 ), s ( 5 , 2 )) call stats % set ( 'uy' , s ( 1 , 2 )) call stats % set ( 'my' , s ( 2 , 2 )) call stats % set ( 'sy' , s ( 3 , 2 )) call stats % set ( 'lqy' , s ( 4 , 2 )) call stats % set ( 'uqy' , s ( 5 , 2 )) call calculate_regression ( s ( 1 , 1 ), s ( 1 , 2 ), a , b , c , sxy ) call stats % set ( 'a' , a ) call stats % set ( 'b' , b ) call stats % set ( 'corr' , c ) call stats % set ( 'cov' , sxy ) write ( 6 , '(/a)' ) 'Regression: y = ax + b' call print_value ( ' gradient a ->' , a ) call print_value ( ' intercept b -> ' , b ) call print_value ( ' covariance cov -> ' , sxy ) call print_value ( 'correlation corr -> ' , c ) end if 10 format ( a , i0 ) end subroutine calculate_stats subroutine calculate_regression ( mean_x , mean_y , a , b , c , sxy ) real ( 8 ), intent ( in ) :: mean_x , mean_y real ( 8 ), intent ( out ) :: a , b , c , sxy integer :: i real ( 8 ) :: sxx , syy sxy = sum ( x_seq ( 1 : n_seq ) * y_seq ( 1 : n_seq )) / n_seq - mean_x * mean_y sxx = sum ( x_seq ( 1 : n_seq ) * x_seq ( 1 : n_seq )) / n_seq - mean_x ** 2 syy = sum ( y_seq ( 1 : n_seq ) * y_seq ( 1 : n_seq )) / n_seq - mean_y ** 2 a = sxy / sxx b = mean_y - a * mean_x c = sxy / sqrt ( sxx * syy ) end subroutine calculate_regression subroutine print_value ( name , x , y ) character ( len =* ), intent ( in ) :: name real ( 8 ), intent ( in ) :: x real ( 8 ), intent ( in ), optional :: y character ( len = :), allocatable :: fmt_x , fmt_y call to_string ( x , fmt_x ) if ( present ( y )) then call to_string ( y , fmt_y ) fmt_x = fmt_x // ' , ' // fmt_y end if write ( 6 , '(a)' ) name // fmt_x end subroutine print_value subroutine summary_stats ( a , mean , median , stddev , lower_q , upper_q ) real ( 8 ), intent ( in ) :: a (:) real ( 8 ), intent ( out ) :: mean , median , stddev , lower_q , upper_q real ( 8 ) :: b ( size ( a )) real ( 8 ) :: s , s2 integer :: m , n n = size ( a ) b = a s = sum ( b ) s2 = sum ( b ** 2 ) mean = s / n stddev = sqrt ( s2 / n - ( s / n ) ** 2 ) call sort ( b ) median = calc_median ( b , m ) if ( n < 3 ) then lower_q = median upper_q = median else lower_q = calc_median ( b ( 1 : m )) if ( mod ( n , 2 ) == 0 ) then upper_q = calc_median ( b ( m + 1 : n )) else upper_q = calc_median ( b ( m : n )) end if end if end subroutine summary_stats function calc_median ( a , mid ) result ( r ) real ( 8 ), intent ( in ) :: a (:) integer , intent ( out ), optional :: mid real ( 8 ) :: r integer :: m , n n = size ( a ) m = n / 2 if ( mod ( n , 2 ) == 0 ) then r = ( a ( m ) + a ( m + 1 )) / 2.0d0 else m = m + 1 r = a ( m ) end if if ( present ( mid )) then mid = m end if end function calc_median ! 'a' won't be very big so a simple n**2 algorithm will do subroutine sort ( a ) real ( 8 ), intent ( inout ) :: a (:) real ( 8 ) :: b ( size ( a )) integer :: i , j ( size ( a )) logical :: mask ( size ( a )) mask = . true . b = a do i = 1 , size ( a ) j = minloc ( b , mask ) associate ( j1 => j ( 1 )) a ( i ) = b ( j1 ) mask ( j1 ) = . false . end associate end do end subroutine subroutine toggle_degrees_mode ( new_mode ) logical , intent ( in ) :: new_mode integer :: i type ( rpn_t ) :: rz ! Only do something if the modes are different if ( new_mode . eqv . degrees_mode ) return degrees_mode = . not . degrees_mode ! Convert all polar complex numbers ! 1) In the stack do i = 1 , stack % ssize rz = stack % peek ( i ) call update_angle_unit ( rz ) call stack % set ( rz , i ) end do ! 2) in memory do i = lbound ( mem , 1 ), ubound ( mem , 1 ) call update_angle_unit ( mem ( i )) end do ! 3) in multiple roots do i = 1 , nroots call update_angle_unit ( roots ( i )) end do end subroutine toggle_degrees_mode subroutine update_angle_unit ( rz ) type ( rpn_t ), intent ( inout ) :: rz complex ( 8 ) :: zs logical :: is_cart zs = rz % get_value ( is_cart ) if ( is_cart ) return zs % im = zs % im * merge ( to_deg , to_rad , degrees_mode ) call rz % set_value ( zs , is_cart ) end subroutine update_angle_unit subroutine invoke_binary ( action ) procedure ( binary_f ), pointer , intent ( in ) :: action type ( rpn_t ) :: us , zs logical :: is_cart zs = stack % pop () if ( complex_mode ) then is_cart = zs % is_cartesian () if (. not . is_cart ) then zs = to_cartesian ( zs ) end if us = stack % peek ( 1 ) if (. not . us % is_cartesian ()) then us = to_polar ( us ) end if us = action ( us , zs ) if (. not . is_cart ) then us = to_polar ( us ) end if call stack % set ( us ) else us = stack % peek ( 1 ) call stack % set ( action ( us , zs )) end if end subroutine invoke_binary subroutine invoke_unary ( action ) procedure ( unary_f ), pointer , intent ( in ) :: action logical :: is_cart type ( rpn_t ) :: z if ( complex_mode ) then z = stack % peek ( 1 ) is_cart = z % is_cartesian () if (. not . is_cart ) then z = to_cartesian ( z ) end if z = action ( z ) if (. not . is_cart ) then z = to_polar ( z ) end if call stack % set ( z ) else call stack % set ( action ( stack % peek ( 1 ))) end if end subroutine invoke_unary integer function nsp ( command ) implicit none character ( * ), intent ( in ) :: command integer :: i do i = 1 , len ( command ) if ( command ( i : i ) /= ' ' ) then nsp = i return end if end do nsp = 0 end function nsp end program hp15c","tags":"","loc":"program/hp15c.html"},{"title":"test_amap – hp","text":"Uses amap Contents Variables my_amap x Source Code test_amap Variables Type Attributes Name Initial type( amap_t ) :: my_amap type( value_t ) :: x Source Code program test_amap use amap implicit none type ( amap_t ) :: my_amap type ( value_t ) :: x call my_amap % set ( 'one' , 1.0d0 ) call my_amap % set ( 'two' , 2.d0 ) call my_amap % set ( 'three' , 3.0d0 ) call my_amap % set ( 'four' , 4.0d0 ) call my_amap % set ( 'five' , 5.0d0 ) call my_amap % print x = my_amap % get ( 'four' ) write ( 6 , '(f0.6)' ) my_amap % get_value ( 'four' ) print * , my_amap % contains ( 'one' ), my_amap % contains ( 'ten' ) end program test_amap","tags":"","loc":"program/test_amap.html"},{"title":"rpn_stack.f90 – hp","text":"Contents Modules rpn_stack Source Code rpn_stack.f90 Source Code 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","tags":"","loc":"sourcefile/rpn_stack.f90.html"},{"title":"rpn_stack_sm.f90 – hp","text":"Contents Submodules stack_sm rpn_sm Source Code rpn_stack_sm.f90 Source Code ! 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 ( 10 0.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 ( 1 0.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","tags":"","loc":"sourcefile/rpn_stack_sm.f90.html"},{"title":"linked_list.f90 – hp","text":"Contents Modules linked_list Source Code linked_list.f90 Source Code module linked_list public type llist private type ( llist_node ), pointer :: begin => null () type ( llist_node ), pointer :: end => null () contains procedure :: iterate => iterate_ll end type llist type llist_node private character ( len = :), allocatable :: data type ( llist_node ), pointer :: next => null () end type llist_node ! Interface for functions being applied to each list element in turn ! when iterating abstract interface subroutine command_fun ( command , ok ) character ( * ), intent ( in ) :: command logical , intent ( out ) :: ok ! Exit the loop if not true end subroutine command_fun end interface contains function iterate_ll ( this , f ) result ( r ) class ( llist ), intent ( inout ), target :: this procedure ( command_fun ) :: f logical :: r type ( llist_node ), pointer :: token token => this % begin do if (. not . associated ( token )) exit call f ( trim ( token % data ), r ) if (. not . r ) then exit end if token => token % next end do end function iterate_ll subroutine append ( lst , data ) type ( llist ), intent ( inout ) :: lst character ( * ), intent ( in ) :: data if (. not . associated ( lst % begin )) then allocate ( lst % begin ) lst % begin % data = data lst % end => lst % begin else allocate ( lst % end % next ) lst % end % next % data = data lst % end => lst % end % next end if end subroutine append subroutine print ( lst ) type ( llist ), intent ( in ) :: lst type ( llist_node ), pointer :: next write ( * , '(a)' ) 'Tokens:' next => lst % begin do if (. not . associated ( next )) exit write ( * , '(4x,a)' ) next % data next => next % next end do end subroutine print integer function size ( lst ) type ( llist ), intent ( inout ) :: lst type ( llist_node ), pointer :: this size = 0 this => lst % begin do if (. not . associated ( this )) exit size = size + 1 this => this % next end do end function size subroutine clear ( lst ) type ( llist ), intent ( inout ) :: lst type ( llist_node ), pointer :: this , next this => lst % begin do if (. not . associated ( this )) exit next => this % next deallocate ( this ) this => next end do nullify ( lst % end ) nullify ( lst % begin ) end subroutine clear end module linked_list","tags":"","loc":"sourcefile/linked_list.f90.html"},{"title":"amap.f90 – hp","text":"Contents Modules amap Source Code amap.f90 Source Code ! Associative map string -> real(8) module amap implicit none ! The key type key_t private character ( len = 16 ) :: k = '-' contains procedure , private :: equals_key_t generic , public :: operator ( == ) => equals_key_t procedure , private :: write_key_t generic , public :: write ( formatted ) => write_key_t procedure , private :: set_to_key_t generic , public :: assignment ( = ) => set_to_key_t end type key_t ! The value type value_t private real ( 8 ) :: v = huge ( 0.0d0 ) ! An out-of-band value contains procedure , private :: write_value_t generic , public :: write ( formatted ) => write_value_t procedure , private :: set_to_value_t generic , public :: assignment ( = ) => set_to_value_t end type value_t ! Map elements are (key,value) pairs type pair_t type ( key_t ) :: k = key_t () type ( value_t ) :: v = value_t () end type pair_t ! The map type amap_t private type ( pair_t ), allocatable :: pairs (:) integer , private :: extent = 10 integer , private :: high_water = 0 contains procedure , public :: get => get_amap_t procedure , public :: get_value => get_value_amap_t procedure , public :: set => set_amap_t procedure , public :: find => find_amap_t procedure , public :: print => print_amap_t procedure , public :: clear => clear_amap_t procedure , private :: is_key_kt procedure , private :: is_key_kvt generic , public :: contains => is_key_kt , is_key_kvt end type amap_t contains subroutine clear_amap_t ( this ) class ( amap_t ), intent ( inout ) :: this if ( allocated ( this % pairs )) then deallocate ( this % pairs ) end if this % high_water = 0 end subroutine clear_amap_t subroutine set_to_key_t ( this , k ) class ( key_t ), intent ( inout ) :: this character ( len =* ), intent ( in ) :: k this % k = adjustl ( k ) end subroutine set_to_key_t subroutine set_to_value_t ( this , v ) class ( value_t ), intent ( inout ) :: this real ( 8 ), intent ( in ) :: v this % v = v end subroutine set_to_value_t subroutine print_amap_t ( this ) class ( amap_t ), intent ( in ) :: this integer :: i write ( 6 , '(a,i0,a)' ) 'Map has ' , this % high_water , ' elements' do i = 1 , this % high_water write ( 6 , '(4x,dt,a,dt)' ) this % pairs ( i )% k , ' -> ' , this % pairs ( i )% v end do end subroutine print_amap_t subroutine set_amap_t ( this , kv , vv ) class ( amap_t ), intent ( inout ) :: this character ( len =* ), intent ( in ) :: kv real ( 8 ), intent ( in ) :: vv type ( pair_t ), allocatable :: tmp_pairs (:) type ( key_t ) :: k type ( value_t ) :: v integer :: idx k = kv v = vv if (. not . allocated ( this % pairs )) then allocate ( this % pairs ( this % extent )) end if idx = this % find ( k ) if ( idx > 0 ) then this % pairs ( idx ) = pair_t ( k , v ) return end if if ( this % high_water == size ( this % pairs )) then allocate ( tmp_pairs ( size ( this % pairs ) + this % extent )) tmp_pairs ( 1 : this % high_water ) = this % pairs call move_alloc ( tmp_pairs , this % pairs ) end if this % high_water = this % high_water + 1 this % pairs ( this % high_water ) = pair_t ( k , v ) end subroutine set_amap_t function find_amap_t ( this , k ) result ( r ) class ( amap_t ), intent ( in ) :: this type ( key_t ), intent ( in ) :: k integer :: r do r = 1 , this % high_water if ( this % pairs ( r )% k == k ) then return end if end do r = 0 end function find_amap_t function get_amap_t ( this , kv ) result ( r ) class ( amap_t ), intent ( in ) :: this character ( len =* ), intent ( in ) :: kv type ( value_t ) :: r type ( key_t ) :: k integer :: idx k = kv idx = this % find ( k ) if ( idx > 0 ) then r = this % pairs ( idx )% v else r = value_t () end if end function get_amap_t function get_value_amap_t ( this , kv ) result ( r ) class ( amap_t ), intent ( in ) :: this character ( len =* ), intent ( in ) :: kv real ( 8 ) :: r type ( value_t ) :: s s = this % get ( kv ) r = s % v end function get_value_amap_t function is_key_kt ( this , k ) result ( r ) class ( amap_t ), intent ( in ) :: this type ( key_t ), intent ( in ) :: k logical :: r r = this % find ( k ) > 0 end function is_key_kt function is_key_kvt ( this , kv ) result ( r ) class ( amap_t ), intent ( in ) :: this character ( len =* ), intent ( in ) :: kv logical :: r r = this % find ( key_t ( kv )) > 0 end function is_key_kvt function equals_key_t ( this , k ) result ( r ) class ( key_t ), intent ( in ) :: this type ( key_t ), intent ( in ) :: k logical :: r r = trim ( adjustl ( this % k )) == trim ( adjustl ( k % k )) end function equals_key_t subroutine write_key_t ( key , unit , iotype , v_list , iostat , iomsg ) class ( key_t ), intent ( in ) :: key integer , intent ( in ) :: unit character ( * ), intent ( in ) :: iotype integer , intent ( in ) :: v_list (:) integer , intent ( out ) :: iostat character ( * ), intent ( inout ) :: iomsg iostat = 0 !iomsg = \"\" write ( 6 , '(a)' , iostat = iostat , iomsg = iomsg ) trim ( adjustl ( key % k )) end subroutine write_key_t subroutine write_value_t ( value , unit , iotype , v_list , iostat , iomsg ) class ( value_t ), intent ( in ) :: value integer , intent ( in ) :: unit character ( * ), intent ( in ) :: iotype integer , intent ( in ) :: v_list (:) integer , intent ( out ) :: iostat character ( * ), intent ( inout ) :: iomsg iostat = 0 !iomsg = \"\" write ( 6 , '(f0.6)' , iostat = iostat , iomsg = iomsg ) value % v end subroutine write_value_t end module amap","tags":"","loc":"sourcefile/amap.f90.html"},{"title":"main.f90 – hp","text":"Contents Programs hp15c Source Code main.f90 Source Code program hp15c use rpn_stack use linked_list , print_ll => print , clear_ll => clear , size_ll => size use amap implicit none real ( 8 ) :: x integer :: ios , i integer :: verbosity = 0 character ( 100 ) :: buff integer :: blen integer :: argl , argc type ( llist ) :: tokens type ( llist_node ), pointer :: token real ( 8 ), parameter :: ag = 9.80665d0 real ( 8 ), parameter :: g = 6.67430d-11 real ( 8 ), parameter :: e = exp ( 1.0d0 ) real ( 8 ), parameter :: c = 2.99792458d8 type ( amap_t ) :: constants type ( amap_t ) :: stats integer :: in_sequence = 0 logical :: seq_is_x real ( 8 ), allocatable :: x_seq (:), y_seq (:) integer :: n_seq = 0 logical :: veMode = . false . logical :: lang_en = . true . logical :: tmp_cmode logical :: ok logical :: getNext , numbers , have_expression integer :: stat character ( len = 100 ) :: msg character ( 5 ) :: lang type ( rpn_t ) :: mem ( 0 : 9 ) = rpn_t () ! Create a stack of size 4 type ( stack_t ( 5 )) :: stack call stack % set_legend ([ 'x:' , 'y:' , 'z:' , 's' , 't:' ]) degrees_mode = . true . complex_mode = . false . eps = 1.0d-14 ! Constants call constants % set ( 'g' , ag ) call constants % set ( 'G' , g ) call constants % set ( 'e' , e ) call constants % set ( 'c' , c ) call constants % set ( 'pi' , pi ) call constants % set ( 'two_pi' , 2 * pi ) call constants % set ( 'pi_over_2' , pi / 2 ) ! Try to read the LANG environment variable call get_environment_variable ( 'LANG' , lang , status = stat ) lang_en = stat /= 0 if (. not . lang_en ) then lang_en = merge (. true .,. false ., lang ( 1 : 3 ) == 'en_' ) end if lang = merge ( 'POINT' , 'COMMA' , lang_en ) call init ( lang ) ! Interrogate argument list argc = command_argument_count () have_expression = . false . do i = 1 , argc call get_command_argument ( i , buff , argl ) if ( buff ( 1 : argl ) == '-d' ) then verbosity = 1 cycle else if ( buff ( 1 : argl ) == '-c' ) then complex_mode = . true . cycle else if ( buff ( 1 : argl ) == '-v' ) then veMode = . true . cycle else if ( buff ( 1 : argl ) == '-h' ) then call help stop end if have_expression = . true . ! Break the string up into a linked-list of tokens call tokenize ( buff ( 1 : argl )) if ( verbosity > 0 ) call print_ll ( tokens ) ! Interpret each token as a command and appky it ok = tokens % iterate ( apply_command ) ! Do not print the stack at the end of a sequence -it's confusing if ( in_sequence /= 2 ) then call stack % print ( veMode ) end if ! Tidy call clear_ll ( tokens ) if (. not . ok ) stop end do if (. not . have_expression ) then call stack % print ( veMode ) end if ! Loop until quit all : do x = 0.0d0 buff = '' write ( 6 , '(a)' , advance = 'no' ) ':: ' read ( 5 , fmt = '(a)' , iostat = ios , iomsg = msg ) buff if ( ios /= 0 ) then write ( 6 , '(/a)' ) 'Command:[' // buff ( 1 : blen ) // ']' // '; ' // msg cycle all end if buff = trim ( adjustl ( buff )) blen = len_trim ( buff ) if ( blen == 0 ) cycle all ! Tokenize input string call tokenize ( buff ( 1 : blen )) ok = tokens % iterate ( apply_command ) if (. not . ok ) exit all if ( in_sequence == 1 ) then write ( 6 , '(i0)' ) n_seq else if ( in_sequence == 2 ) then in_sequence = 0 else call stack % print ( veMode ) end if end do all call clear_ll ( tokens ) stop contains subroutine tokenize ( com ) character ( * ), intent ( in ) :: com integer :: start , end character ( len = :), allocatable :: command call clear_ll ( tokens ) if ( len_trim ( com ) == 0 ) then return end if start = 1 ! Ensure there are no leading and trailing spaces command = trim ( adjustl ( com )) end = index ( command , ' ' ) end = merge ( len ( command ), end - 1 , end == 0 ) do call append ( tokens , command ( start : end )) if ( end == len ( command )) exit start = end + nsp ( command ( end + 1 :)) end = index ( command ( start :), ' ' ) - 1 end = merge ( len ( command ), end + start - 1 , end == - 1 ) end do end subroutine tokenize subroutine help write ( 6 , '(/a)' ) 'Command Calculator' write ( 6 , '(a/)' ) '==================' write ( 6 , '(a)' ) 'Introduction' write ( 6 , '(a/)' ) '------------' write ( 6 , '(a)' ) 'This is a command-line calculator. It supports both real and complex modes, as well' write ( 6 , '(a)' ) 'as degrees/radians selection and precision control. It can be run interactively or as an' write ( 6 , '(a/)' ) 'expression parser. This help is deliberately terse to encourage exploration.' write ( 6 , '(a/)' ) '-------------------------------------------------------------------------------' write ( 6 , '(a)' ) 'Operators: + - * / ^ ^/x ^x ^2 ^/2 ^3 ^/3 ^*2 ^*10 || ! %' write ( 6 , '(a)' ) 'Constants: pi e g G c two_pi pi_over_2' write ( 6 , '(a)' ) 'Functions: sin cos tan asin acos atan sinh cosh tanh log2 log lg len sq sqrt cb cbrt' write ( 6 , '(a)' ) ' alog2 alog alog10 gamma ncr npr rem int nint' write ( 6 , '(a)' ) ' Controls: fix[0-9] clx cl cla ' write ( 6 , '(a)' ) ' Modes: real complex verbose terse degrees radians' write ( 6 , '(a)' ) ' Memories: n=0...9 st<n> sw<n> rc<n> cl<n> m<n>+ m<n>- m<n>* m<n>/ msh' write ( 6 , '(a)' ) ' Complex: ri _ || to_pol to_cart' write ( 6 , '(a)' ) ' Actions: 1/ -- R r ? > < split drop' write ( 6 , '(a)' ) ' Stats: { x1 x2 ... } { x1,y1 x2,y2 ... }' write ( 6 , '(a)' ) ' n ux sx mx lqx uqx uy sy my lqy uqy a b cov corr' write ( 6 , '(a/)' ) ' Quits: q' write ( 6 , '(a/)' ) '-------------------------------------------------------------------------------' write ( 6 , '(a)' ) 'Examples' write ( 6 , '(a)' ) '--------' write ( 6 , '(4x,a)' ) 'hp \"fix2 18 2 - 8 2 / * =\" -> 64.00' write ( 6 , '(4x,a)' ) 'hp \"2 -- complex sqrt =\" -> (0.00000,-1.414214)' write ( 6 , '(4x,a/)' ) 'hp -c \"radians (1,pi_over_2)p ^ * degrees =\" -> (1.000000,180.000000) p' end subroutine help subroutine apply_command ( command , ok ) use , intrinsic :: ieee_arithmetic implicit none character ( * ), intent ( in ) :: command logical , intent ( out ) :: ok real ( 8 ) :: r , im , ang complex ( 8 ) :: u , z real ( 8 ), allocatable :: tmp_seq (:) type ( rpn_t ) :: us , zs logical :: is_cart integer :: m , idx character ( len = 1 ) :: comma character ( 5 ), parameter :: lang ( 2 ) = [ 'POINT' , 'COMMA' ] ok = . true . if ( len_trim ( command ) == 0 ) then return end if if ( verbosity > 0 ) then write ( * , '(a)' ) 'Applying: ' // command end if if ( in_sequence == 1 ) then if ( command == '}' ) then in_sequence = 2 complex_mode = tmp_cmode call calculate_stats else ! All elements must be the same so either all x or all x,y idx = index ( command , ',' ) if ( n_seq == 0 ) then seq_is_x = ( idx == 0 ) end if if ( seq_is_x . neqv . ( idx == 0 )) then goto 901 end if if ( seq_is_x ) then read ( command , * , err = 901 ) r im = 0 else read ( command ( 1 : idx - 1 ), * , err = 901 ) r read ( command ( idx + 1 : len ( command )), * , err = 901 ) im end if ! Initial allocation if ( n_seq == 0 . and . . not . allocated ( x_seq )) then allocate ( x_seq ( 10 )) if (. not . seq_is_x ) then allocate ( y_seq ( 10 )) end if end if if ( n_seq < size ( x_seq )) then n_seq = n_seq + 1 else ! Expand array allocate ( tmp_seq ( n_seq + 10 )) tmp_seq ( 1 : n_seq ) = x_seq call move_alloc ( tmp_seq , x_seq ) if (. not . seq_is_x ) then allocate ( tmp_seq ( n_seq + 10 )) tmp_seq ( 1 : n_seq ) = y_seq call move_alloc ( tmp_seq , y_seq ) end if end if x_seq ( n_seq ) = r if (. not . seq_is_x ) then y_seq ( n_seq ) = im end if if ( verbosity > 0 ) then print * , x_seq ( 1 : n_seq ) end if end if return end if select case ( command ) case ( 'q' , 'quit' ) ok = . false . return case ( '=' ) ok = . false . return case ( '{' ) ! Start sequence in_sequence = 1 n_seq = 0 tmp_cmode = complex_mode complex_mode = . false . call stats % clear () case ( '--' ) call invoke_unary ( chs_fr ) case ( '^' ) call stack % push ( stack % peek ( 1 )) case ( '+' ) call invoke_binary ( add_fr ) case ( '-' ) call invoke_binary ( subtract_fr ) case ( '*' ) call invoke_binary ( multiply_fr ) case ( '/' ) call invoke_binary ( divide_fr ) case ( '^x' ) call invoke_binary ( power_fr ) case ( '^/x' ) ! Only raising to a real power is supported zs = stack % peek ( 1 ) if ( zs % is_real ()) then call invoke_binary ( root_fr ) else goto 901 end if case ( '>' ) call invoke_unary ( next_root_fr ) case ( '<' ) call invoke_unary ( previous_root_fr ) case ( '%' ) call invoke_binary ( percent_fr ) case ( 'xy' , 'XY' ) call stack % swap case ( 'R' ) call stack % rotate_down case ( 'r' ) call stack % rotate_up case ( 'CLA' , 'cla' ) call stack % clear mem = rpn_t () call stats % clear case ( 'CL' , 'cl' ) call stack % clear case ( 'CLX' , 'clx' ) call stack % set ( rpn_t ()) case ( '_' ) if ( complex_mode ) then call invoke_unary ( conj_fr ) endif case ( 'len' , '||' ) if ( complex_mode ) then call invoke_unary ( len_fr ) ! Length is always reported as (x,0) and marked is_cartesian zs = stack % peek ( 1 ) call zs % set_value ( is_cartesian = . true .) call stack % set ( zs , 1 ) else zs = stack % peek ( 1 ) z = zs % get_value () us = stack % peek ( 2 ) u = us % get_value () call zs % set_value ( cmplx ( hypot ( z % re , u % re ), 0 , 8 )) call stack % set ( zs ) end if case ( 'split' ) if (. not . complex_mode ) then zs = stack % pop () x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if im = x - r call stack % push ( im ) call stack % push ( r ) end if case ( 'int' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if call zs % set_value ( cmplx ( r , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'nint' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () r = nint ( x ) if ( mod ( r , 2.0d0 ) == 1 ) then r = r - 1 end if call zs % set_value ( cmplx ( r , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'rem' ) if (. not . complex_mode ) then zs = stack % peek ( 1 ) x = zs % get_value () if ( x > 0 ) then r = floor ( x ) else r = ceiling ( x ) end if im = x - r call zs % set_value ( cmplx ( im , 0 , 8 )) call stack % set ( zs , 1 ) end if case ( 'drop' ) zs = stack % pop () case ( 'ri' ) ! Swap real and imaginary parts if ( complex_mode ) then call invoke_unary ( swap_real_imaginary_fr ) end if case ( 'to_pol' ) ! Convert x + iy to r + i theta if ( complex_mode ) then zs = stack % peek ( 1 ) call stack % set ( to_polar ( zs )) end if case ( 'to_cart' ) ! Convert (r,theta) to (x,y) if ( complex_mode ) then zs = stack % peek ( 1 ) call stack % set ( to_cartesian ( zs )) end if case ( '1/' ) call invoke_unary ( reciprocal_fr ) case ( '^2' , 'sq' ) call invoke_unary ( power_2_fr ) case ( '^/2' , 'sqrt' ) call invoke_unary ( sqrt_fr ) case ( '^3' , 'cb' ) call invoke_unary ( power_3_fr ) case ( '^/3' , 'cbrt' ) call invoke_unary ( cbrt_fr ) case ( '^*2' , 'alog2' ) call invoke_unary ( exp_2_fr ) case ( '^*10' , 'alog10' ) call invoke_unary ( exp_10_fr ) case ( 'exp' , 'alog' ) call invoke_unary ( exp_e_fr ) case ( 'ln' ) call invoke_unary ( ln_fr ) case ( 'log2' ) call invoke_unary ( log2_fr ) case ( 'lg' ) call invoke_unary ( lg_fr ) case ( 'sinh' ) call invoke_unary ( hsine_fr ) case ( 'cosh' ) call invoke_unary ( hcosine_fr ) case ( 'tanh' ) call invoke_unary ( htangent_fr ) case ( 'sin' ) call invoke_unary ( sine_fr ) case ( 'cos' ) call invoke_unary ( cosine_fr ) case ( 'tan' ) call invoke_unary ( tangent_fr ) case ( 'asin' ) call invoke_unary ( asine_fr ) case ( 'asinh' ) call invoke_unary ( ahsine_fr ) case ( 'acos' ) call invoke_unary ( acosine_fr ) case ( 'acosh' ) call invoke_unary ( ahcosine_fr ) case ( 'atan' ) call invoke_unary ( atangent_fr ) case ( 'atanh' ) call invoke_unary ( ahtangent_fr ) case ( 'atan2' ) call invoke_binary ( atangent2_fr ) case ( 'gamma' ) call invoke_unary ( gamma_fr ) case ( '!' ) zs = stack % peek ( 1 ) if ( zs % is_positive_real ()) then call invoke_unary ( fact_fr ) else goto 901 end if case ( 'ncr' ) zs = stack % peek ( 1 ) us = stack % peek ( 2 ) if ( zs % is_positive_real () . and . us % is_positive_real ()) then call invoke_binary ( ncr_fr ) else goto 901 end if case ( 'npr' ) zs = stack % peek ( 1 ) us = stack % peek ( 2 ) if ( zs % is_positive_real () . and . us % is_positive_real ()) then call invoke_binary ( npr_fr ) else goto 901 end if case ( 'm0+' , 'm1+' , 'm2+' , 'm3+' , 'm4+' , 'm5+' , 'm6+' , 'm7+' , 'm8+' , 'm9+' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) + stack % peek ( 1 ) case ( 'm0-' , 'm1-' , 'm2-' , 'm3-' , 'm4-' , 'm5-' , 'm6-' , 'm7-' , 'm8-' , 'm9-' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) - stack % peek ( 1 ) case ( 'm0*' , 'm1*' , 'm2*' , 'm3*' , 'm4*' , 'm5*' , 'm6*' , 'm7*' , 'm8*' , 'm9*' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) * stack % peek ( 1 ) case ( 'm0/' , 'm1/' , 'm2/' , 'm3/' , 'm4/' , 'm5/' , 'm6/' , 'm7/' , 'm8/' , 'm9/' ) read ( command ( 2 : 2 ), '(i1)' , err = 901 ) m mem ( m ) = mem ( m ) / stack % peek ( 1 ) case ( 'st0' , 'st1' , 'st2' , 'st3' , 'st4' , 'st5' , 'st6' , 'st7' , 'st8' , 'st9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m mem ( m ) = stack % peek ( 1 ) case ( 'sw0' , 'sw1' , 'sw2' , 'sw3' , 'sw4' , 'sw5' , 'sw6' , 'sw7' , 'sw8' , 'sw9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m zs = stack % peek ( 1 ) call stack % set ( mem ( m )) mem ( m ) = zs case ( 'rc0' , 'rc1' , 'rc2' , 'rc3' , 'rc4' , 'rc5' , 'rc6' , 'rc7' , 'rc8' , 'rc9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m call stack % push ( mem ( m )) case ( 'cl0' , 'cl1' , 'cl2' , 'cl3' , 'cl4' , 'cl5' , 'cl6' , 'cl7' , 'cl8' , 'cl9' ) read ( command ( 3 : 3 ), '(i1)' , err = 901 ) m mem ( m ) = rpn_t () case ( 'msh' ) write ( 6 , '(i3,a,dt)' ) ( i , ': ' , mem ( i ), i = 0 , size ( mem ) - 1 ) case ( 'fix0' , 'fix1' , 'fix2' , 'fix3' , 'fix4' , 'fix5' , 'fix6' , 'fix7' , 'fix8' , 'fix9' ) read ( command ( 4 : 4 ), '(i1)' ) m call set_places ( m ) case ( 'DEG' , 'deg' , 'DEGREES' , 'degrees' ) call toggle_degrees_mode (. true .) case ( 'RAD' , 'rad' , 'RADIANS' , 'radians' ) call toggle_degrees_mode (. false .) case ( 'mC' , 'COMPLEX' , 'complex' ) complex_mode = . true . case ( 'mR' , 'REAL' , 'real' ) complex_mode = . false . case ( 'mV' , 'VERBOSE' , 'verbose' ) veMode = . true . case ( 'mT' , 'TERSE' , 'terse' ) veMode = . false . case ( '?' ) write ( 6 , advance = 'no' , fmt = '(a)' ) 'Status: ' write ( 6 , advance = 'no' , fmt = '(2a)' ) merge ( 'degrees' , 'radians' , degrees_mode ), ' ; ' write ( 6 , advance = 'no' , fmt = '(a,i0)' ) 'dp = ' , get_places () if ( complex_mode ) then write ( 6 , advance = 'no' , fmt = '(a)' ) ' ; mode = complex' else write ( 6 , advance = 'no' , fmt = '(a)' ) ' ; mode = real' end if write ( 6 , advance = 'no' , fmt = '(a,i0)' ) ' ; stack size = ' , stack % get_size () write ( 6 , '(a/)' ) '' case ( 'help' , 'h' ) call help case default ! Process constants first block integer :: lc , is_integer , split_idx , end_idx character ( len = :), allocatable :: re_comp , im_comp lc = len_trim ( command ) is_integer = ( index ( command , '.' ) == 0 ) if ( complex_mode ) then if ( command ( 1 : 1 ) == '(' ) then split_idx = index ( command , ',' ) end_idx = index ( command , ')' ) re_comp = command ( 2 : split_idx - 1 ) im_comp = command ( split_idx + 1 : end_idx - 1 ) if ( constants % contains ( re_comp )) then z % re = constants % get_value ( re_comp ) else read ( re_comp , * , err = 901 , end = 901 ) z % re end if if ( constants % contains ( im_comp )) then z % im = constants % get_value ( im_comp ) else read ( im_comp , * , err = 901 , end = 901 ) z % im end if if ( command ( lc : lc ) == 'p' ) then call stack % push ( z ,. false .) else call stack % push ( z ) end if else if ( constants % contains ( command )) then x = constants % get_value ( command ) else read ( command , * , err = 901 , end = 901 ) x end if call stack % push ( cmplx ( x , 0.0d0 , 8 )) end if else if ( constants % contains ( command )) then x = constants % get_value ( command ) else if ( stats % contains ( command )) then x = stats % get_value ( command ) else read ( command , * , err = 901 , end = 901 ) x end if call stack % push ( cmplx ( x , 0.0d0 , 8 )) end if end block end select return 901 continue write ( 6 , '(a)' ) command // ' ???' return end subroutine apply_command subroutine calculate_stats real ( 8 ) :: a , b , c , sxy real ( 8 ) :: s ( 5 , 2 ) call summary_stats ( x_seq ( 1 : n_seq ), s ( 1 , 1 ), s ( 2 , 1 ), s ( 3 , 1 ), s ( 4 , 1 ), s ( 5 , 1 )) call stats % set ( 'n' , real ( n_seq , 8 )) call stats % set ( 'ux' , s ( 1 , 1 )) call stats % set ( 'mx' , s ( 2 , 1 )) call stats % set ( 'sx' , s ( 3 , 1 )) call stats % set ( 'lqx' , s ( 4 , 1 )) call stats % set ( 'uqx' , s ( 5 , 1 )) if ( seq_is_x ) then write ( 6 , 10 ) ' count n -> ' , n_seq call print_value ( ' mean ux -> ' , s ( 1 , 1 )) call print_value ( ' stddev sx -> ' , s ( 3 , 1 )) call print_value ( ' median mx -> ' , s ( 2 , 1 )) call print_value ( 'lower_q lqx -> ' , s ( 4 , 1 )) call print_value ( 'upper_q uqx -> ' , s ( 5 , 1 )) else call summary_stats ( y_seq ( 1 : n_seq ), s ( 1 , 2 ), s ( 2 , 2 ), s ( 3 , 2 ), s ( 4 , 2 ), s ( 5 , 2 )) write ( 6 , 10 ) ' count n -> ' , n_seq call print_value ( ' means ux , uy -> ' , s ( 1 , 1 ), s ( 1 , 2 )) call print_value ( ' stddevs sx , xy -> ' , s ( 3 , 1 ), s ( 3 , 2 )) call print_value ( ' medians mx , my -> ' , s ( 2 , 1 ), s ( 2 , 2 )) call print_value ( 'lower_qs lqx , lqy -> ' , s ( 4 , 1 ), s ( 4 , 2 )) call print_value ( 'upper_qs uqx , uqy -> ' , s ( 5 , 1 ), s ( 5 , 2 )) call stats % set ( 'uy' , s ( 1 , 2 )) call stats % set ( 'my' , s ( 2 , 2 )) call stats % set ( 'sy' , s ( 3 , 2 )) call stats % set ( 'lqy' , s ( 4 , 2 )) call stats % set ( 'uqy' , s ( 5 , 2 )) call calculate_regression ( s ( 1 , 1 ), s ( 1 , 2 ), a , b , c , sxy ) call stats % set ( 'a' , a ) call stats % set ( 'b' , b ) call stats % set ( 'corr' , c ) call stats % set ( 'cov' , sxy ) write ( 6 , '(/a)' ) 'Regression: y = ax + b' call print_value ( ' gradient a ->' , a ) call print_value ( ' intercept b -> ' , b ) call print_value ( ' covariance cov -> ' , sxy ) call print_value ( 'correlation corr -> ' , c ) end if 10 format ( a , i0 ) end subroutine calculate_stats subroutine calculate_regression ( mean_x , mean_y , a , b , c , sxy ) real ( 8 ), intent ( in ) :: mean_x , mean_y real ( 8 ), intent ( out ) :: a , b , c , sxy integer :: i real ( 8 ) :: sxx , syy sxy = sum ( x_seq ( 1 : n_seq ) * y_seq ( 1 : n_seq )) / n_seq - mean_x * mean_y sxx = sum ( x_seq ( 1 : n_seq ) * x_seq ( 1 : n_seq )) / n_seq - mean_x ** 2 syy = sum ( y_seq ( 1 : n_seq ) * y_seq ( 1 : n_seq )) / n_seq - mean_y ** 2 a = sxy / sxx b = mean_y - a * mean_x c = sxy / sqrt ( sxx * syy ) end subroutine calculate_regression subroutine print_value ( name , x , y ) character ( len =* ), intent ( in ) :: name real ( 8 ), intent ( in ) :: x real ( 8 ), intent ( in ), optional :: y character ( len = :), allocatable :: fmt_x , fmt_y call to_string ( x , fmt_x ) if ( present ( y )) then call to_string ( y , fmt_y ) fmt_x = fmt_x // ' , ' // fmt_y end if write ( 6 , '(a)' ) name // fmt_x end subroutine print_value subroutine summary_stats ( a , mean , median , stddev , lower_q , upper_q ) real ( 8 ), intent ( in ) :: a (:) real ( 8 ), intent ( out ) :: mean , median , stddev , lower_q , upper_q real ( 8 ) :: b ( size ( a )) real ( 8 ) :: s , s2 integer :: m , n n = size ( a ) b = a s = sum ( b ) s2 = sum ( b ** 2 ) mean = s / n stddev = sqrt ( s2 / n - ( s / n ) ** 2 ) call sort ( b ) median = calc_median ( b , m ) if ( n < 3 ) then lower_q = median upper_q = median else lower_q = calc_median ( b ( 1 : m )) if ( mod ( n , 2 ) == 0 ) then upper_q = calc_median ( b ( m + 1 : n )) else upper_q = calc_median ( b ( m : n )) end if end if end subroutine summary_stats function calc_median ( a , mid ) result ( r ) real ( 8 ), intent ( in ) :: a (:) integer , intent ( out ), optional :: mid real ( 8 ) :: r integer :: m , n n = size ( a ) m = n / 2 if ( mod ( n , 2 ) == 0 ) then r = ( a ( m ) + a ( m + 1 )) / 2.0d0 else m = m + 1 r = a ( m ) end if if ( present ( mid )) then mid = m end if end function calc_median ! 'a' won't be very big so a simple n**2 algorithm will do subroutine sort ( a ) real ( 8 ), intent ( inout ) :: a (:) real ( 8 ) :: b ( size ( a )) integer :: i , j ( size ( a )) logical :: mask ( size ( a )) mask = . true . b = a do i = 1 , size ( a ) j = minloc ( b , mask ) associate ( j1 => j ( 1 )) a ( i ) = b ( j1 ) mask ( j1 ) = . false . end associate end do end subroutine subroutine toggle_degrees_mode ( new_mode ) logical , intent ( in ) :: new_mode integer :: i type ( rpn_t ) :: rz ! Only do something if the modes are different if ( new_mode . eqv . degrees_mode ) return degrees_mode = . not . degrees_mode ! Convert all polar complex numbers ! 1) In the stack do i = 1 , stack % ssize rz = stack % peek ( i ) call update_angle_unit ( rz ) call stack % set ( rz , i ) end do ! 2) in memory do i = lbound ( mem , 1 ), ubound ( mem , 1 ) call update_angle_unit ( mem ( i )) end do ! 3) in multiple roots do i = 1 , nroots call update_angle_unit ( roots ( i )) end do end subroutine toggle_degrees_mode subroutine update_angle_unit ( rz ) type ( rpn_t ), intent ( inout ) :: rz complex ( 8 ) :: zs logical :: is_cart zs = rz % get_value ( is_cart ) if ( is_cart ) return zs % im = zs % im * merge ( to_deg , to_rad , degrees_mode ) call rz % set_value ( zs , is_cart ) end subroutine update_angle_unit subroutine invoke_binary ( action ) procedure ( binary_f ), pointer , intent ( in ) :: action type ( rpn_t ) :: us , zs logical :: is_cart zs = stack % pop () if ( complex_mode ) then is_cart = zs % is_cartesian () if (. not . is_cart ) then zs = to_cartesian ( zs ) end if us = stack % peek ( 1 ) if (. not . us % is_cartesian ()) then us = to_polar ( us ) end if us = action ( us , zs ) if (. not . is_cart ) then us = to_polar ( us ) end if call stack % set ( us ) else us = stack % peek ( 1 ) call stack % set ( action ( us , zs )) end if end subroutine invoke_binary subroutine invoke_unary ( action ) procedure ( unary_f ), pointer , intent ( in ) :: action logical :: is_cart type ( rpn_t ) :: z if ( complex_mode ) then z = stack % peek ( 1 ) is_cart = z % is_cartesian () if (. not . is_cart ) then z = to_cartesian ( z ) end if z = action ( z ) if (. not . is_cart ) then z = to_polar ( z ) end if call stack % set ( z ) else call stack % set ( action ( stack % peek ( 1 ))) end if end subroutine invoke_unary integer function nsp ( command ) implicit none character ( * ), intent ( in ) :: command integer :: i do i = 1 , len ( command ) if ( command ( i : i ) /= ' ' ) then nsp = i return end if end do nsp = 0 end function nsp end program hp15c","tags":"","loc":"sourcefile/main.f90.html"},{"title":"test_amap.f90 – hp","text":"Contents Programs test_amap Source Code test_amap.f90 Source Code program test_amap use amap implicit none type ( amap_t ) :: my_amap type ( value_t ) :: x call my_amap % set ( 'one' , 1.0d0 ) call my_amap % set ( 'two' , 2.d0 ) call my_amap % set ( 'three' , 3.0d0 ) call my_amap % set ( 'four' , 4.0d0 ) call my_amap % set ( 'five' , 5.0d0 ) call my_amap % print x = my_amap % get ( 'four' ) write ( 6 , '(f0.6)' ) my_amap % get_value ( 'four' ) print * , my_amap % contains ( 'one' ), my_amap % contains ( 'ten' ) end program test_amap","tags":"","loc":"sourcefile/test_amap.f90.html"}]} |