Fortraneries/Fraktalism/mods/fractcolmap.f90

124 lines
3.2 KiB
Fortran

module fractcolmap
use pixrgb ! from Modules dir
implicit none
integer :: currmap(0:255, 3)
logical :: initialized = .FALSE.
contains
!-----------------------------------------------------
subroutine fcolm_infos(msg)
character(*), intent(in) :: msg
write(0, *) ' -> fractcolmap infos because [', msg, ']'
write(0, *) ' initialized is ', initialized
end subroutine
!-----------------------------------------------------
subroutine fcolm_load_mapfile(fname)
character(*), intent(in) :: fname
integer :: io, errcode, idx
integer :: ir, ig, ib
write(0, *) ' -> fractcolmap load file [', fname, ']'
! trying to get access to the datas
open(newunit=io, file=fname, iostat=errcode, action='read')
if (errcode .NE. 0) then
write(0, *) ' errcode :', errcode
write(0, *) ' FILE ', fname, ' NOT FOUND'
STOP 'BECAUSE FULL NUCKED, SORRY'
endif
! loop over all the data
do idx=0, 255
read(io, *) ir, ig, ib
! write(*, '("idx ", I5, " got rgb", 3I6)') idx, ir, ig, ib
currmap(idx, 1) = ir
currmap(idx, 2) = ig
currmap(idx, 3) = ib
enddo
! a few cleanup
close(io)
end subroutine
!-----------------------------------------------------
!-
! draw all the colors in a nice picture
!-
subroutine fcolm_plot_mapfile(fname)
character(*), intent(in) :: fname
type(t_pixrgb), allocatable :: prgb(:,:)
integer :: errcode, ix, iy, xx
integer :: rgb(3)
write(0, *) ' -> fractcolmap plot map to [', fname, ']'
allocate(prgb(512, 128), stat=errcode)
if (0 .NE. errcode) then
write(0, *) "errcode allocate in plot_map: ", errcode
STOP 'ABEND'
endif
call rgbpix_set_to_zero(prgb)
! print *, ' FILE ', fname
do ix = 1, 255
call fcolm_get_rgb(ix, rgb)
xx = ix * 2
! print *, ix, xx, " => ", rgb
do iy=1, 128
prgb( xx, iy)%r = rgb(1)
prgb(1+xx, iy)%r = rgb(1)
prgb( xx, iy)%g = rgb(2)
prgb(1+xx, iy)%g = rgb(2)
prgb( xx, iy)%b = rgb(3)
prgb(1+xx, iy)%b = rgb(3)
enddo
enddo
! write(0, *) 'first pixel', prgb(1, 1)
!- push all the colred dats to disk
call rgbpix_spit_as_pnm_8(prgb, fname)
deallocate(prgb)
end subroutine
!-----------------------------------------------------
subroutine fcolm_get_rgb(idx, rgb)
integer, intent(in) :: idx
integer, intent(out) :: rgb(3)
rgb(1) = max(min(currmap(idx, 1), 255), 0) ! Red
rgb(2) = max(min(currmap(idx, 2), 255), 0) ! Green
rgb(3) = max(min(currmap(idx, 3), 255), 0) ! Blue
end subroutine
!-----------------------------------------------------
subroutine fcolm_make_gray()
integer :: idx
do idx=0, 255
currmap(idx, 1) = idx
currmap(idx, 2) = idx
currmap(idx, 3) = idx
enddo
initialized = .TRUE.
end subroutine
!-----------------------------------------------------
subroutine fcolm_print_map()
integer :: idx
do idx=0, 255
print *, currmap(idx, 1), currmap(idx, 2), currmap(idx, 3)
enddo
end subroutine
!-----------------------------------------------------
end module