166 lines
4.3 KiB
Fortran
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
|
|
|
|
|