Continued fraction/Arithmetic/G(matrix ng, continued fraction n): Difference between revisions

Content added Content deleted
Line 2,971: Line 2,971:
{{trans|ATS}}
{{trans|ATS}}
{{trans|C}}
{{trans|C}}

'''WARNING: THIS IS BROKEN. I am fixing it right now.'''


Unlike the ATS and C implementations upon which this Fortran code is based, there is no garbage collector. The memory management is tricky, and if you find bugs in it, please feel free to fix them.
Unlike the ATS and C implementations upon which this Fortran code is based, there is no garbage collector. The memory management is tricky, and if you find bugs in it, please feel free to fix them.


(Fortran standards allow garbage collection, but the NAG compiler is the only Fortran compiler I know of that offers garbage collection as an option. I am using GNU Fortran.)
(Fortran standards allow garbage collection, but the NAG compiler is the only Fortran compiler I know of that offers garbage collection as an option. I am using GNU Fortran.)

I have been liberal in the use of '''recursive''' declarations and '''block''' constructs. In this program they can only help, not hurt.


<syntaxhighlight lang="fortran">
<syntaxhighlight lang="fortran">
Line 3,058: Line 3,058:
contains
contains


subroutine cf_generator_make (gen, proc, env)
recursive subroutine cf_generator_make (gen, proc, env)
type(cf_generator_t), intent(out), pointer :: gen
type(cf_generator_t), intent(out), pointer :: gen
interface
interface
Line 3,084: Line 3,084:
end subroutine cf_generator_t_refcount_decr
end subroutine cf_generator_t_refcount_decr


subroutine cf_generator_t_finalize (gen)
recursive subroutine cf_generator_t_finalize (gen)
type(cf_generator_t), intent(inout) :: gen
type(cf_generator_t), intent(inout) :: gen
deallocate (gen%env)
deallocate (gen%env)
Line 3,099: Line 3,099:
end subroutine cf_memo_t_refcount_decr
end subroutine cf_memo_t_refcount_decr


subroutine cf_memo_t_finalize (memo)
recursive subroutine cf_memo_t_finalize (memo)
type(cf_memo_t), intent(inout) :: memo
type(cf_memo_t), intent(inout) :: memo
deallocate (memo%storage)
deallocate (memo%storage)
end subroutine cf_memo_t_finalize
end subroutine cf_memo_t_finalize


subroutine cf_make (cf, gen)
recursive subroutine cf_make (cf, gen)
type(cf_t), pointer, intent(out) :: cf
type(cf_t), pointer, intent(out) :: cf
type(cf_generator_t), pointer, intent(inout) :: gen
type(cf_generator_t), pointer, intent(inout) :: gen
Line 3,122: Line 3,122:
end subroutine cf_make
end subroutine cf_make


subroutine cf_t_finalize (cf)
recursive subroutine cf_t_finalize (cf)
type(cf_t), intent(inout) :: cf
type(cf_t), intent(inout) :: cf


Line 3,132: Line 3,132:
end subroutine cf_t_finalize
end subroutine cf_t_finalize


subroutine cf_generator_make_from_cf (gen, cf)
recursive subroutine cf_generator_make_from_cf (gen, cf)
!
!
! TAKE NOTE: deallocating gen DOES NOT deallocate cf. (Most likely
! TAKE NOTE: deallocating gen DOES NOT deallocate cf. (Most likely
Line 3,151: Line 3,151:
end subroutine cf_generator_make_from_cf
end subroutine cf_generator_make_from_cf


subroutine cf_generator_from_cf_proc (env, term_exists, term)
recursive subroutine cf_generator_from_cf_proc (env, term_exists, term)
class(*), intent(inout) :: env
class(*), intent(inout) :: env
logical, intent(out) :: term_exists
logical, intent(out) :: term_exists
Line 3,163: Line 3,163:
end subroutine cf_generator_from_cf_proc
end subroutine cf_generator_from_cf_proc


subroutine cf_get_more_terms (cf, needed)
recursive subroutine cf_get_more_terms (cf, needed)
class(cf_t), intent(inout) :: cf
class(cf_t), intent(inout) :: cf
integer, intent(in) :: needed
integer, intent(in) :: needed
Line 3,193: Line 3,193:
end subroutine cf_get_more_terms
end subroutine cf_get_more_terms


subroutine cf_update (cf, needed)
recursive subroutine cf_update (cf, needed)
class(cf_t), intent(inout) :: cf
class(cf_t), intent(inout) :: cf
integer, intent(in) :: needed
integer, intent(in) :: needed


integer, pointer :: storage1(:)
integer, pointer :: storage1(:)
integer :: i


if (cf%terminated .or. needed <= cf%m) then
if (cf%terminated .or. needed <= cf%m) then
Line 3,208: Line 3,207:
cf%n = 2 * needed
cf%n = 2 * needed
allocate (storage1(0:cf%n - 1))
allocate (storage1(0:cf%n - 1))
storage1(0:cf%m) = cf%memo%storage(0:cf%m)
storage1(0:cf%m - 1) = cf%memo%storage(0:cf%m - 1)
deallocate (cf%memo%storage)
deallocate (cf%memo%storage)
cf%memo%storage => storage1
cf%memo%storage => storage1
Line 3,215: Line 3,214:
end subroutine cf_update
end subroutine cf_update


subroutine cf_get_at (cf, i, term_exists, term)
recursive subroutine cf_get_at (cf, i, term_exists, term)
class(cf_t), intent(inout) :: cf
class(cf_t), intent(inout) :: cf
integer, intent(in) :: i
integer, intent(in) :: i
Line 3,226: Line 3,225:
end subroutine cf_get_at
end subroutine cf_get_at


function cf2string_max_terms (cf, max_terms) result (s)
recursive function cf2string_max_terms (cf, max_terms) result (s)
class(cf_t), intent(inout) :: cf
class(cf_t), intent(inout) :: cf
integer, intent(in) :: max_terms
integer, intent(in) :: max_terms
Line 3,277: Line 3,276:
end function cf2string_max_terms
end function cf2string_max_terms


function cf2string_default_max_terms (cf) result (s)
recursive function cf2string_default_max_terms (cf) result (s)
class(cf_t), intent(inout) :: cf
class(cf_t), intent(inout) :: cf
character(len = :), allocatable :: s
character(len = :), allocatable :: s
Line 3,305: Line 3,304:
contains
contains


subroutine r2cf_generator_make (gen, n, d)
recursive subroutine r2cf_generator_make (gen, n, d)
type(cf_generator_t), pointer, intent(out) :: gen
type(cf_generator_t), pointer, intent(out) :: gen
integer, intent(in) :: n, d
integer, intent(in) :: n, d
Line 3,320: Line 3,319:
end subroutine r2cf_generator_make
end subroutine r2cf_generator_make


subroutine r2cf_generator_proc (env, term_exists, term)
recursive subroutine r2cf_generator_proc (env, term_exists, term)
class(*), intent(inout) :: env
class(*), intent(inout) :: env
logical, intent(out) :: term_exists
logical, intent(out) :: term_exists
Line 3,345: Line 3,344:
end subroutine r2cf_generator_proc
end subroutine r2cf_generator_proc


subroutine r2cf_make (cf, n, d)
recursive subroutine r2cf_make (cf, n, d)
type(cf_t), pointer, intent(out) :: cf
type(cf_t), pointer, intent(out) :: cf
integer, intent(in) :: n, d
integer, intent(in) :: n, d
Line 3,378: Line 3,377:
contains
contains


subroutine sqrt2_generator_make (gen)
recursive subroutine sqrt2_generator_make (gen)
type(cf_generator_t), pointer, intent(out) :: gen
type(cf_generator_t), pointer, intent(out) :: gen


Line 3,391: Line 3,390:
end subroutine sqrt2_generator_make
end subroutine sqrt2_generator_make


subroutine sqrt2_generator_proc (env, term_exists, term)
recursive subroutine sqrt2_generator_proc (env, term_exists, term)
class(*), intent(inout) :: env
class(*), intent(inout) :: env
logical, intent(out) :: term_exists
logical, intent(out) :: term_exists
Line 3,404: Line 3,403:
end subroutine sqrt2_generator_proc
end subroutine sqrt2_generator_proc


subroutine sqrt2_make (cf)
recursive subroutine sqrt2_make (cf)
type(cf_t), pointer, intent(out) :: cf
type(cf_t), pointer, intent(out) :: cf


Line 3,436: Line 3,435:
contains
contains


subroutine hfunc_generator_make (gen, a1, a, b1, b, source_gen)
recursive subroutine hfunc_generator_make (gen, a1, a, b1, b, source_gen)
type(cf_generator_t), pointer, intent(out) :: gen
type(cf_generator_t), pointer, intent(out) :: gen
integer, intent(in) :: a1, a, b1, b
integer, intent(in) :: a1, a, b1, b
Line 3,455: Line 3,454:
end subroutine hfunc_generator_make
end subroutine hfunc_generator_make


subroutine hfunc_generator_proc (env, term_exists, term)
recursive subroutine hfunc_generator_proc (env, term_exists, term)
class(*), intent(inout) :: env
class(*), intent(inout) :: env
logical, intent(out) :: term_exists
logical, intent(out) :: term_exists
Line 3,465: Line 3,464:
select type (env)
select type (env)
class is (hfunc_generator_env_t)
class is (hfunc_generator_env_t)

done = .false.
done = .false.
do while (.not. done)
do while (.not. done)
Line 3,489: Line 3,487:
env%b1 = a1 - (b1 * q)
env%b1 = a1 - (b1 * q)
env%b = a - (b * q)
env%b = a - (b * q)
⚫
term_exists = .true.
⚫
term = q
done = .true.
end block
end block
term_exists = .true.
end if
term = q
end if
⚫
done = .true.
⚫
end if
end if


if (.not. done) then
if (.not. done) then
call env%source_gen%proc (env%source_gen%env, term_exists, term)
call env%source_gen%proc (env%source_gen%env, term_exists, term)
if (term_exists) then
if (term_exists) then
block
block
integer :: a1, a, b1, b
integer :: a1, a, b1, b
a1 = env%a1
a1 = env%a1
a = env%a
a = env%a
b1 = env%b1
b1 = env%b1
b = env%b
b = env%b
env%a1 = a + (a1 * term)
env%a1 = a + (a1 * term)
env%a = a1
env%a = a1
env%b1 = b + (b1 * term)
env%b1 = b + (b1 * term)
env%b = b1
env%b = b1
end block
end block
else
else
env%a = env%a1
env%a = env%a1
env%b = env%b1
env%b = env%b1
end if
end if
end if
end if
end do
end do


Line 3,521: Line 3,519:
end subroutine hfunc_generator_proc
end subroutine hfunc_generator_proc


subroutine hfunc_make (cf, a1, a, b1, b, source_cf)
recursive subroutine hfunc_make (cf, a1, a, b1, b, source_cf)
type(cf_t), pointer, intent(out) :: cf
type(cf_t), pointer, intent(out) :: cf
integer, intent(in) :: a1, a, b1, b
integer, intent(in) :: a1, a, b1, b
Line 3,558: Line 3,556:
type(cf_t), pointer :: cf_one_way
type(cf_t), pointer :: cf_one_way
type(cf_t), pointer :: cf_another_way
type(cf_t), pointer :: cf_another_way

type(cf_t), pointer :: cf_half_of_1_div_sqrt2
type(cf_t), pointer :: cf_a_third_way


call r2cf_make (cf_13_11, 13, 11)
call r2cf_make (cf_13_11, 13, 11)
Line 3,570: Line 3,571:
call hfunc_make (cf_one_way, 1, 2, 0, 4, cf_sqrt2)
call hfunc_make (cf_one_way, 1, 2, 0, 4, cf_sqrt2)
call hfunc_make (cf_another_way, 1, 1, 0, 2, cf_1_div_sqrt2)
call hfunc_make (cf_another_way, 1, 1, 0, 2, cf_1_div_sqrt2)

call hfunc_make (cf_half_of_1_div_sqrt2, 1, 0, 0, 2, cf_1_div_sqrt2)
call hfunc_make (cf_a_third_way, 2, 1, 0, 2, cf_half_of_1_div_sqrt2)


write (*, '("13/11 => ", A)') cf2string (cf_13_11)
write (*, '("13/11 => ", A)') cf2string (cf_13_11)
Line 3,582: Line 3,586:
write (*, '("(2 + sqrt(2))/4 => ", A)') cf2string (cf_one_way)
write (*, '("(2 + sqrt(2))/4 => ", A)') cf2string (cf_one_way)
write (*, '("(1 + 1/sqrt(2))/2 => ", A)') cf2string (cf_another_way)
write (*, '("(1 + 1/sqrt(2))/2 => ", A)') cf2string (cf_another_way)
write (*, '("(1/sqrt(2))/2 + 1/2 => ", A)') cf2string (cf_a_third_way)


deallocate (cf_13_11)
deallocate (cf_13_11)
Line 3,593: Line 3,598:
deallocate (cf_one_way)
deallocate (cf_one_way)
deallocate (cf_another_way)
deallocate (cf_another_way)
deallocate (cf_half_of_1_div_sqrt2)
deallocate (cf_a_third_way)


end program univariate_continued_fraction_task
end program univariate_continued_fraction_task
Line 3,600: Line 3,607:


{{out}}
{{out}}
<pre>$ gfortran -g -std=f2018 univariate_continued_fraction_task.f90 && ./a.out
<pre>$ gfortran -fbounds-check -Wall -Wextra -g -std=f2018 univariate_continued_fraction_task.f90 && ./a.out
13/11 => [1;5,2]
13/11 => [1;5,2]
22/7 => [3;7]
22/7 => [3;7]
Line 3,610: Line 3,617:
1/sqrt(2) => [0;1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,...]
1/sqrt(2) => [0;1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,...]
(2 + sqrt(2))/4 => [0;1,5,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,...]
(2 + sqrt(2))/4 => [0;1,5,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,...]
(1 + 1/sqrt(2))/2 => [0;1,5,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,...]</pre>
(1 + 1/sqrt(2))/2 => [0;1,5,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,...]
(1/sqrt(2))/2 + 1/2 => [0;1,5,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,4,1,...]</pre>


=={{header|Go}}==
=={{header|Go}}==
Retrieved from "https://rosettacode.org/wiki/Continued_fraction/Arithmetic/G(matrix_ng,_continued_fraction_n)"