124 lines
3.2 KiB
Fortran
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
|
|
|