fractint color maps module 1st shoot

Fraktalism/mods/fractcolmap.f90

@@ -0,0 +1,118 @@
+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)
+  ! Please, add a molly-guard
+  if (0 .NE. errcode) then
+    write(0, *) "errcode allocate in plot_map: ", errcode
+    STOP 'ABEND'
+  endif
+
+  print *, ' FILE ', fname
+  do ix = 1, 255
+     call fcolm_get_rgb(ix-1, 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
+
+  ! 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
+