Fortraneries/Modules/trials.f90

!-
!	This module try to write PNM complient files - ymmv
!-
module trials

  use   pixrgb

    implicit none

    contains
!-------------------------------------------------------------------
!  please write the same thing for RGB 16bits pictures !

subroutine new_spit_gray(pic, fname)

  integer, intent(in), dimension (:,:)  ::  pic
  character (len=*), intent(in)         ::  fname

  integer                               ::  foo, io, ix, iy
  integer                               ::  buffer(8), ptr

  ! print *, "newspit a, largeur  ", size(pic, 1), ubound(pic, 1)
  ! print *, "newspit a, hauteur  ", size(pic, 2), ubound(pic, 2)
  ! print *, "newspit a, buffer   ", size(buffer, 1)

  open(newunit=io, file=fname)
  write (io, '(a2)') "P2"
  write (io, '("# new_spit_gray")')
  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)
      foo = pic(ix, iy)
      if (foo .GT. 65535)  foo = 65535
      buffer(ptr) = foo
      ptr = ptr + 1
      if (ptr .EQ. size(buffer, 1)+1) then
        write(io, "(8(' ',i0))") buffer
        ptr = 1
      endif
    enddo
  enddo

  close(io)

end subroutine
!-------------------------------------------------------------------
!-
!          CAUTION: there was NO out-of-bounds check !
!-
subroutine new_spit_rgb16(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, "(12(' ', 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