dither.fortran

gistfile1.fortran

program dither
  integer              :: status,unit,readwrite,blocksize,naxes(2),nfound
  integer              :: group,npixels,bitpix,naxis,i,j,fpixel,un
  real                 :: nullval,diff_mat(3,2),perr
  real, allocatable    :: image(:,:), error(:,:)
  integer, allocatable :: seed(:)
  logical              :: anynull,simple,extend
  character(len=80)    :: filename

  call random_seed(size=Nrand)
  allocate(seed(Nrand))
  open(newunit=un,file="/dev/urandom",access="stream",&
       form="unformatted",action="read",status="old")
  read(un) seed
  close(un)
  call random_seed(put=seed)
  deallocate(seed)

  status=0
  call ftgiou(unit,status)
  filename='PUPPY.FITS'
  readwrite=0
  call ftopen(unit,filename,readwrite,blocksize,status)
  call ftgknj(unit,'NAXIS',1,2,naxes,nfound,status)
  call ftgidt(unit,bitpix,status)
  npixels=naxes(1)*naxes(2)
  group=1
  nullval=-999
  allocate(image(naxes(1),naxes(2)))
  allocate(error(naxes(1)+1,naxes(2)+1))
  call ftgpve(unit,group,1,npixels,nullval,image,anynull,status)
  call ftclos(unit, status)
  call ftfiou(unit, status)

  diff_mat=0.0
  diff_mat(3,1) = 2.0 
  diff_mat(1,2) = 1.0
  diff_mat(2,2) = 1.0
  diff_mat=diff_mat/5.0

  error=0.0
  perr=0
  do j=1,naxes(2)
    do i=1,naxes(1)
      p=max(min(image(i,j)+error(i,j),255.0),0.0)
      if (p < 127.0) then
        perr=p
        image(i,j)=0.0
      else
        perr=p-255.0
        image(i,j)=255.0
      endif
      call random_number(r)
      r=0.6*(r-0.5)
      error(i+1,j)=  error(i+1,j)  +perr*(diff_mat(3,1)+r)
      error(i-1,j+1)=error(i-1,j+1)+perr*diff_mat(1,2)
      error(i  ,j+1)=error(i ,j+1) +perr*(diff_mat(2,2)-r)
    end do
  end do

  call ftgiou(unit,status)
  blocksize=1
  filename='PUPPY-OUT.FITS'
  call ftinit(unit,filename,blocksize,status)
  simple=.true.
  naxis=2
  extend=.true.
  call ftphpr(unit,simple,bitpix,naxis,naxes,0,1,extend,status)
  group=1
  fpixel=1
  call ftppre(unit,group,fpixel,npixels,image,status)
  call ftclos(unit, status)
  call ftfiou(unit, status)

  deallocate(image)
  deallocate(error)
end program dither