Fortraneries/Modules/pixrgb.f90

166 lines
4.3 KiB
Fortran

!-
! 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 !
!-
! The width of the picture MUST be a multiple of 4 !
!-
subroutine rgbpix_spit_as_pnm_16(pic, fname)
type(t_pixrgb), intent(in) :: pic(:,:)
character (len=*), intent(in) :: fname
integer :: io, ix, iy
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
! XXX may be we have to flush our internal buffer ?
close(unit=io)
end subroutine
!-------------------------------------------------------------------
end module