c these two subroutines are used to write an array in a 2D Postscript
c greyscale lattice.  
c
c (There is one kludge:  the output file is opened in psinit, but not
c closed until pswrite --> this may affect performance.)  
c
c Written by Erik Draeger, 11/16/98

      subroutine psinit(npixels,ln,filename)
      implicit none

      integer ln,npixels
      character*30 filename

      open(ln,file=filename)
      write(ln,'(a)') '%!PS-Adobe-2.0'
      write(ln,'(a)') '%%Creator: Erik Draeger'
      write(ln,'(a)') '%'
      write(ln,*) '/npts{',npixels,'} bind def'
      write(ln,*) '/pixel {'
      write(ln,*) '  newpath'
      write(ln,*) '  0 0 moveto'
      write(ln,*) '  npts 0 lineto'
      write(ln,*) '  npts npts lineto'
      write(ln,*) '  0 npts lineto'
      write(ln,*) '  closepath'
      write(ln,*) '  fill'
      write(ln,*) '} def'
      write(ln,*) ''
      write(ln,*) '/nextpixel {' 
      write(ln,*) '  setrgbcolor'
      write(ln,*) '  npts 0 translate'
      write(ln,*) '  pixel'
      write(ln,*) '} def'
      write(ln,*) ''
      write(ln,*) '/nextrow {'
      write(ln,*) '  setrgbcolor'
      write(ln,*) '  0 npts translate'
      write(ln,*) '  pixel'
      write(ln,*) '} def'
      write(ln,*) '/outline {'
      write(ln,*) '  newpath'
      write(ln,*) '  0 0 moveto'
      write(ln,*) '  npts 0 lineto'
      write(ln,*) '  npts npts lineto'
      write(ln,*) '  0 npts lineto'
      write(ln,*) '  closepath' 
      write(ln,*) '  stroke'
      write(ln,*) '} def'
      write(ln,*) ''
      write(ln,*) '0.0 setlinewidth'
      write(ln,*) '/initial save def'
      close(ln)

      return
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine pswrite(array,m)
      implicit none
      include 'walk.cm'

      integer m,array(m)
      integer i,j,ln,npixels,xtran,ytran
      real*8 color(3)

c determine the greyscale (shade defined by a greyscale value between
c 0 and 1:  1 = white, 0 = black)

      ln = lun(1)   ! assigned lun for .ps file = lun(1)
      call openapp(ln,psfile)

      if (greynorm.le.0.) then
        greynorm = 0.
        do i=1,m
          greynorm = max(array(i),greynorm)
        enddo
      endif

      write(*,*) 'greyscale normalization (value for solid black) =',
     &  greynorm
      call openapp(lun(4),outfile)
      write(lun(4),*) 'greyscale normalization =',greynorm
      close(lun(4))

c write out first pixel

      call assigncolor(array(1),color,greynorm)

      write(ln,20) (color(j),j=1,3),' setrgbcolor'
      write(ln,*) 'pixel'
      write(ln,*) 'gsave'

c write out the rest

      do i=2,m
        call assigncolor(array(i),color,greynorm)
cewd TEMP
c        if (initfood(i).eq.1) then
c          color(1) = 0.
c          color(2) = 0.
c          color(3) = 1.
c        endif
cewd TEMP
        if (mod(i,n1d).eq.1) then   ! start on the next row
          write(ln,*) ''
          write(ln,*) 'grestore'
          write(ln,20) (color(j),j=1,3),' nextrow'
          write(ln,*) 'gsave'
          write(ln,*) ''
        else
          write(ln,20) (color(j),j=1,3),' nextpixel'
        endif
      enddo

c outline food sites
      if (showfood.eq.1) then
        write(ln,*) 'initial restore' ! puts us back at the origin
        write(ln,*) '/final save def'
        write(ln,*) '0. 1. 0. setrgbcolor' ! outline in green

        npixels = outres/n1d    ! number of pixels per lattice site
        xtran = 0
        ytran = 0

        do i=1,msites
          if (mod(i,n1d).eq.1.and.i.gt.n1d) then
            ytran = ytran + npixels
            xtran = xtran-(n1d)*npixels
          endif
          if (initfood(i).eq.1) then
            write(ln,*) xtran,ytran,' translate'
            write(ln,*) 'outline'
            xtran = npixels
            ytran = 0
          else
            xtran = xtran + npixels
          endif
        enddo
      else
        write(ln,*) 'initial restore' ! puts us back at the origin
        write(ln,*) '/final save def'
      endif

c draw a box around the system
      write(ln,*) 'final restore'
      write(ln,*) '0. setlinewidth'
      write(ln,*) '0. 0. 0. setrgbcolor'    ! black
      write(ln,*) 'newpath'
      write(ln,*) '0 0 moveto'
      write(ln,*) outres,' 0 lineto'
      write(ln,*) outres,outres,' lineto'
      write(ln,*) '0 ',outres,' lineto'
      write(ln,*) 'closepath'
      write(ln,*) 'stroke'

      write(ln,*) 'showpage'
      close(ln)

 20   format(3f12.8,a14)

      return
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine assigncolor(val,color,greynorm)
      implicit none
      
      integer val,i
      real*8 ratio,greynorm,color(3)

      if (val.ge.0) then
        do i=1,3
          ratio = val/(1.0*greynorm)
          color(i) = 1. - ratio
          if (ratio.lt.0.03.and.ratio.gt.0.) color(i) = 0.97
        enddo
      elseif (val.eq.-10) then   ! red
        color(1) = 1.
        color(2) = 0.
        color(3) = 0.
      elseif (val.eq.-20) then   ! yellow
        color(1) = 1.
        color(2) = 1.
        color(3) = 0.
      elseif (val.eq.-30) then   ! green
        color(1) = 0.
        color(2) = 1.
        color(3) = 0.
      elseif (val.eq.-40) then   ! cyan
        color(1) = 0.
        color(2) = 1.
        color(3) = 1.
      elseif (val.eq.-50) then   ! blue
        color(1) = 0.
        color(2) = 0.
        color(3) = 1.
      elseif (val.eq.-60) then   ! magenta
        color(1) = 1.
        color(2) = 0.
        color(3) = 1.
      endif

      return
      end

