Fortraneries/Fraktalism/mods/fractcolmap.f90

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