Fortraneries/Modules/pixrgb.f90

!-
!	This module try to write PNM complient RGB files
!                ONLY ASCII MODE IS SUPPORTED !
!-
module pixrgb
    implicit none
!-----------------------------------------------------------------------
!-
!      definition of structures
!-
type t_pixrgb
  integer           :: r, g, b
  integer           :: alpha = 0
end type
!-------------------------------------------------------------------
contains
!-------------------------------------------------------------------
!-
!	try FORALL here
!-
subroutine rgbpix_set_to_zero(pic)
  type(t_pixrgb), intent(out)       ::  pic(:,:)
  integer                           ::  ix, iy
  do iy=1, ubound(pic, 2)
    do ix=1, ubound(pic, 1)
      pic(ix, iy)%r = 0
      pic(ix, iy)%g = 0
      pic(ix, iy)%b = 0
    enddo
  enddo
end subroutine
!-------------------------------------------------------------------
!-
!	set all the pixels to a RGB value
!-
subroutine rgbpix_set_to_rgb(pic, r, g, b)
  type(t_pixrgb), intent(out)       ::  pic(:,:)
  integer, intent(in)               :: r, g, b
  integer                           ::  ix, iy
  do iy=1, ubound(pic, 2)
    do ix=1, ubound(pic, 1)
      pic(ix, iy)%r = r
      pic(ix, iy)%g = g
      pic(ix, iy)%b = b
    enddo
  enddo
end subroutine

!-------------------------------------------------------------------
!-
!		NOT TESTED !!!
!-
subroutine rgb_pix_clamp_at_8(pic)
  type(t_pixrgb), intent(inout)     ::  pic(:,:)
  integer                           ::  ix, iy
  do iy=1, ubound(pic, 2)
    do ix=1, ubound(pic, 1)
      pic(ix, iy)%r = max(0, min(pic(ix, iy)%r, 255))
      pic(ix, iy)%g = max(0, min(pic(ix, iy)%g, 255))
      pic(ix, iy)%b = max(0, min(pic(ix, iy)%b, 255))
    enddo
  enddo
end subroutine
!-------------------------------------------------------------------
!-
!          CAUTION: there was NO out-of-bounds check !
!-
subroutine rgbpix_spit_as_pnm_8(pic, fname)
  type(t_pixrgb), intent(in)       ::  pic(:,:)
  character (len=*), intent(in)    ::  fname

  integer                               ::  io, ix, iy

  open(newunit=io, file=fname)
  write (io, '(a2)') "P3"
  write (io, '("# rgbpix_spit_as_pnm_8")')
  write (io, '(i0,"  ",i0)')  size(pic, 1), size(pic, 2)
  write (io, '(i0)') 255

  do iy=1, ubound(pic, 2)
    do ix=1, ubound(pic, 1)
      write(io, "(I0,' ', I0,' ',I0)")            &
              pic(ix, iy)%r, pic(ix, iy)%g, pic(ix, iy)%b
    enddo
  enddo
  close(unit=io)

end subroutine
!-------------------------------------------------------------------
!-
!          CAUTION: there was NO out-of-bounds check !
!-
subroutine rgbpix_spit_as_pnm_16_old(pic, fname)

  type(t_pixrgb), intent(in)       ::  pic(:,:)
  character (len=*), intent(in)    ::  fname

  integer                               ::  io, ix, iy

  open(newunit=io, file=fname)
  write (io, '(a2)') "P3"
  write (io, '("# rgbpix_spit_as_pnm_16")')
  write (io, '(i0," ",i0)')  size(pic, 1), size(pic, 2)
  write (io, '(i0)') 65535

  do iy=1, ubound(pic, 2)
    do ix=1, ubound(pic, 1)
      write(io, "(I0,' ', I0,' ',I0)")         &
         pic(ix, iy)%r, pic(ix, iy)%g, pic(ix, iy)%b
    enddo
  enddo
  close(unit=io)

end subroutine
!-------------------------------------------------------------------
!-
!          CAUTION: there was NO out-of-bounds check !
!-
subroutine rgbpix_spit_as_pnm_16(pic, fname)

  type(t_pixrgb), intent(in)       ::  pic(:,:)
  character (len=*), intent(in)    ::  fname

  integer                          ::  io, ix, iy, ik
  integer                          ::  buffer(3*4), ptr

  ! write(0, *) ">>> subroutine rgbpix_spit_as_pnm_16"

  open(newunit=io, file=fname)
  write (io, '(a2)') "P3"
  write (io, '("# rgbpix_spit_as_pnm_16")')
  write (io, '(i0," ",i0)')  size(pic, 1), size(pic, 2)
  write (io, '(i0)') 65535

  buffer = 0
  ptr = 1

  do iy=1, ubound(pic, 2)
    do ix=1, ubound(pic, 1)

      buffer(ptr)   = pic(ix, iy)%r
      buffer(ptr+1) = pic(ix, iy)%g
      buffer(ptr+2) = pic(ix, iy)%b
      ptr = ptr + 3

      if (ptr .EQ. 13) then
        write(io, "(i0, 11(' ', i0))") buffer
        ptr = 1
      endif
    enddo    ! write(io, *) " fin iy=", iy
  enddo

!   may be we have to flush the buffer ?

  close(unit=io)

end subroutine

!-------------------------------------------------------------------

end module