921 lines
27 KiB
Fortran
921 lines
27 KiB
Fortran
|
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
|