Fortraneries/Fraktalism/fraktals.f90

225 lines
5.9 KiB
Fortran
Raw Normal View History

2022-02-12 21:00:57 +01:00
module fraktals
2022-03-08 10:36:32 +01:00
use points3d
2022-02-12 21:00:57 +01:00
implicit none
contains
2022-10-28 21:53:57 +02:00
!===============================================================
! nouveau 28 mai 2022 (again)
! source:
! Fractal Creation with FRACTINT
!
subroutine parasites_0(pic, cx, cy, maxiter)
implicit none
! here is the wtf
integer, intent(inout), dimension (:,:) :: pic
real, intent(in) :: cx, cy
integer, intent(in) :: maxiter
integer :: ix, iy, width, height
real :: fx, fy, coef
logical :: burps
! write(0, *) "subroutine parasites_0" , maxiter
! write(0, *) "constantes", cx, cy
width = ubound(pic, 1) ; height = ubound(pic, 2)
coef = float(maxiter)
do ix = 1, width
fx = cx + (float(ix) / (float(width)/4.0) - 2.0)
burps = (RAND() .lt. 0.01)
do iy = 1, height
fy = cy + (float(iy) / (float(height)/4.0) - 2.0)
if (burps) then
pic(ix, iy) = int(fx * fy * coef * 1.005)
else
pic(ix, iy) = int(fx * fy * coef)
endif
enddo
enddo
end subroutine parasites_0
!===============================================================
2022-02-12 23:27:59 +01:00
subroutine simple_julia(pic, cx, cy, maxiter)
2022-02-12 21:00:57 +01:00
implicit none
integer, intent(inout), dimension (:,:) :: pic
real, intent(in) :: cx, cy
2022-02-12 23:27:59 +01:00
integer, intent(in) :: maxiter
2022-02-12 21:00:57 +01:00
integer :: ix, iy, width, height
real :: fx, fy
complex :: Z, C
2022-02-12 23:27:59 +01:00
integer :: iter
2022-02-14 14:15:10 +01:00
logical :: over_iter
2022-02-12 21:00:57 +01:00
width = ubound(pic, 1)
height = ubound(pic, 2)
C = complex(cx, cy)
2022-02-14 14:15:10 +01:00
print *, "Const = ", C
2022-02-12 21:00:57 +01:00
2022-03-30 08:42:39 +02:00
! ready ? ok, clear the picture
pic = 0
2022-02-12 21:00:57 +01:00
do ix = 1, width
fx = (float(ix) / (float(width)/4.0) - 2.0)
do iy = 1, height
fy = (float(iy) / (float(height)/4.0) - 2.0)
! ------ traitement du pixel
2022-02-14 14:15:10 +01:00
iter = 0 ; over_iter = .FALSE.
2022-02-12 21:00:57 +01:00
Z = complex(fx, fy)
2022-02-14 14:15:10 +01:00
do while (modulus2(Z) .LT. 4.0)
2022-02-12 21:00:57 +01:00
Z = (Z * Z) + C
iter = iter + 1
2022-02-14 14:15:10 +01:00
if (iter .GE. maxiter) then
over_iter = .TRUE.
exit
endif
2022-02-12 21:00:57 +01:00
2022-02-14 14:15:10 +01:00
end do
2022-02-12 21:00:57 +01:00
2022-02-14 14:15:10 +01:00
if (over_iter) then
pic(ix, iy) = 0
else
2022-03-30 08:42:39 +02:00
pic(ix, iy) = iter*12
2022-02-14 14:15:10 +01:00
endif
2022-03-30 08:42:39 +02:00
enddo ! iy
enddo ! ix
2022-02-12 21:00:57 +01:00
2022-02-14 14:15:10 +01:00
end subroutine simple_julia
2022-10-28 21:53:57 +02:00
!===============================================================
2022-02-16 00:18:35 +01:00
! d'après les pages 91/92 du livre de Roger T Stevens
! "Fractal programming in C"
!
2022-03-08 10:36:32 +01:00
subroutine compute_pickover(array, coefs)
type(t_point3d), dimension(:) :: array
double precision, dimension(4) :: coefs
2022-02-14 14:15:10 +01:00
double precision :: xa, ya, za, xb, yb, zb
2022-03-08 10:36:32 +01:00
integer :: i
! print *, "coefs ", coefs
2022-02-14 14:15:10 +01:00
2022-03-30 08:42:39 +02:00
! write(0, '(1X, A18, I9)') "compute pickover ", ubound(array, 1)
2022-02-14 14:15:10 +01:00
2022-03-30 08:42:39 +02:00
xa = 1.0 ; ya = 1.0 ; za = 1.0
2022-02-14 14:15:10 +01:00
2022-03-08 10:36:32 +01:00
do i=1, ubound(array, 1)
xb = sin(coefs(1)*ya) - za*cos(coefs(2)*xa)
yb = za*sin(coefs(3)*xa) - cos(coefs(4)*ya)
2022-02-14 14:15:10 +01:00
zb = sin(xa)
2022-03-08 10:36:32 +01:00
array(i)%x = xb
array(i)%y = yb
array(i)%z = zb
array(i)%seq = i
2022-02-14 14:15:10 +01:00
xa = xb ; ya = yb ; za = zb
enddo
2022-03-08 10:36:32 +01:00
end subroutine
!-----------------------------------------------------
!
! d'après les pages 91/92 du livre de Roger T Stevens
! "Fractal programming in C"
!
2022-03-18 23:36:56 +01:00
subroutine plot_pickover(pic, count)
2022-03-08 10:36:32 +01:00
implicit none
integer, intent(inout), dimension (:,:) :: pic
integer, intent(in) :: count
type(t_point3d), dimension(:), allocatable :: points
double precision, dimension(4) :: coefs
integer :: i, w, h, px, py, errcode
write(0, '(1X, A18 , I9)') "pickover_0 ", count
allocate(points(count), stat=errcode)
if (0 .NE. errcode) then
STOP " : NO ENOUGH MEMORY"
endif
2022-03-30 08:42:39 +02:00
! Clear the picture
pic = 0
2022-03-08 10:36:32 +01:00
coefs(1) = 2.24 ; coefs(2) = 0.43
coefs(3) = -0.65 ; coefs(4) = -2.43
call compute_pickover(points, coefs)
w = ubound(pic, 1)
h = ubound(pic, 2)
do i=1, ubound(points, 1)
2022-03-30 08:42:39 +02:00
px = int((points(i)%x * (w/4.09)) + (w / 2))
py = int((points(i)%y * (h/4.09)) + (h / 2))
pic(px, py) = 255 ! WARNING COREDUMP ?
2022-03-08 10:36:32 +01:00
enddo
deallocate(points)
2022-03-18 23:36:56 +01:00
end subroutine plot_pickover
2022-03-08 10:36:32 +01:00
2022-10-28 21:53:57 +02:00
!===============================================================
2022-03-08 10:36:32 +01:00
!
! d'après les pages NN/NN du livre de Roger T Stevens
! "Fractal programming in C"
!
subroutine lorentz_0(pic, count)
implicit none
integer, intent(inout), dimension (:,:) :: pic
integer, intent(in) :: count
! XXX double precision :: xa, ya, za, xb, yb, zb
! XXX double precision :: ka, kb, kc, kd
! XXX integer :: i, w, h, px, py
2022-11-30 02:53:05 +01:00
write(0, *) "lorentz_0, picz is ", ubound(pic)
write(0, *) "lorentz_0, count is ", count
2022-03-08 10:36:32 +01:00
end subroutine lorentz_0
2022-10-28 21:53:57 +02:00
!===============================================================
2022-02-14 14:15:10 +01:00
! -- some support functions --
2022-03-08 10:36:32 +01:00
!-----------------------------------------------------------
2022-04-15 17:13:07 +02:00
! usage : evolvopick & voxelize
2022-10-28 21:53:57 +02:00
subroutine interp4dp (ina, inb, out, dpk)
2022-04-04 19:40:04 +02:00
double precision, dimension(4), intent(in) :: ina, inb
double precision, dimension(4), intent(out) :: out
double precision, intent(in) :: dpk
integer :: foo
do foo=1, 4
out(foo) = (ina(foo) * (1.0-dpk)) + (inb(foo) * (dpk))
enddo
2022-03-08 10:36:32 +01:00
2022-10-28 21:53:57 +02:00
end subroutine
2022-03-08 10:36:32 +01:00
!-----------------------------------------------------------
2022-02-14 14:15:10 +01:00
2022-02-12 21:00:57 +01:00
function dist0 (x, y)
implicit none
real, intent(in) :: x, y
real :: dist0
dist0 = ( x*x + y*y )
end function
2022-03-08 10:36:32 +01:00
!-----------------------------------------------------------
2022-02-12 21:00:57 +01:00
function modulus2(pt)
implicit none
complex, intent(in) :: pt
real :: modulus2
modulus2 = real(pt)*real(pt) + imag(pt)*imag(pt)
end
!-----------------------------------------------------
end module fraktals