!- ! This module try to write PNM complient files - ymmv !- module spitpgm implicit none contains !------------------------------------------------------------------- !- ! This subroutine try to scale the values to fit the 16 bit range ! subroutine spit_as_pgm_eq(pic, fname) integer, intent(in), dimension (:,:) :: pic character (len=*), intent(in) :: fname integer :: io, foo integer :: ix, iy real :: fk, fpix write(0, '(1X, A)') "> spit_as_pgm_eq to " // trim(fname) open(newunit=io, file=fname) write (io, '(a2)') "P2" write (io, '(i0," ",i0)') size(pic, 1), size(pic, 2) write (io, '(i0)') 65535 foo = MAXVAL(pic) if (foo .EQ. 0) then print *, " IS SOMETHING WRONG GOING TO HAPPEN ?" do ix = 1, size(pic) write (io, "(i0)") 0 enddo else fk = float(foo) / 65535.01 write (0, *) " max pix value", foo, " fk ", fk do iy = 1, ubound(pic, 2) do ix = 1, ubound(pic, 1) fpix = float(pic(ix, iy)) / fk write (io, "(i0)") int(fpix) end do end do endif close(io) end subroutine !------------------------------------------------------------------- !- ! 16 bits - 65535 levels portable grey map file !- subroutine spit_as_pgm_16(pic, fname) integer, intent(in), dimension (:,:) :: pic character (len=*), intent(in) :: fname integer :: io, foo integer :: ix, iy open(newunit=io, file=fname) write (io, '(a2)') "P2" write (io, '("# size:", I9)') size(pic) 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) foo = pic(ix, iy) if (foo .GT. 65535) foo = 65535 write(io, "(i0)") foo enddo enddo close(io) end subroutine !------------------------------------------------------------------- subroutine spit_as_pgm_8(pic, fname) integer, intent(in), dimension (:,:) :: pic character (len=*), intent(in) :: fname integer :: io, foo integer :: ix, iy ! XXX print *, "> spit_as_pgm_8 to ", fname foo = MAXVAL(pic) ! XXX print *, " max = ", foo open(newunit=io, file=fname) write (io, '(a2)') "P2" 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) foo = pic(ix, iy) if (foo .GT. 255) foo = 255 write(io, "(i0)") foo enddo enddo close(io) end subroutine !------------------------------------------------------------------- end module spitpgm