gif_util.f90

FDTD algorithm.

module gif_util

!  Conversion of raster data to GIF format.
!
!  Version 1.0, February 1998
!
!  Written by Jos Bergervoet
!

use bin_io
implicit none         !  Check all declarations
private               !  bin_io is used private, no transfer to main program

public  :: writegif   !  Writes GIF89 image, given pixel array and color map

private :: giflzw, slicewrite, InitTable, flushbuffer

type, public :: color
  integer  :: r, g, b
end type color

integer, parameter, private     :: F_unit=92, Bufend=260
character(len=Bufend), private  :: buf
integer, private  ::  ibuf                            ! output buffer vars

integer, parameter, private  ::    maxcode = 4095 
integer, parameter, private  ::    nocode = maxcode+1 ! definitions for LZW

! Define LZW code tables for hashing:
character(len=1), private, dimension(0:maxcode+1)  :: endbyte
integer, private, dimension(0:maxcode)             :: follow, next
  !
  ! For any code P, which codes for a sequence af pixel-values, endbyte(P)
  ! is the last pixel-value, follow(P) points to another code (if it exists)
  ! which codes for this same sequence, but with one more pixel-value
  ! appended.
  !   For each code P, next(P) points to another code which codes for a
  ! similar sequence with only the endbyte different. This is a hashing
  ! pointer, for fast look-up.
  !   All pointers are 'nocode' if they point to nothing
  !
  
integer, private :: ncod, curmaxcode, EOI, CC, P, K, child, &
                    maxbase, skip, slen, blen, accum, nout   ! local vars

contains

subroutine flushbuffer()
! Flushes up to 255 bytes to output file if buffer contains data, keeping
! rest of data in buffer. If skip>0 there is a partially filled last byte
! in buf[ibuf]. This byte will be written only if ibuf<256. That should be
! the last call to flushbuffer.

  integer  :: bl    !   number of bytes to write (to be determined)

  if (ibuf > 255) then
    bl = 255        !   we will write buf[1..255]
  else if (skip /= 0) then
    bl = ibuf       !   buf[ibuf] is partially used, write buf[1..ibuf]
  else if (ibuf > 1) then
    bl = ibuf-1     !   write buf[1..ibuf-1], there is no partial byte
  else
    return          !   nothing to write
  end if

  call integer_block_write (F_unit, bl, 1)
  call char_block_write ( F_unit, buf(1:bl) )
  buf(1:ibuf-bl) = buf(bl+1:ibuf) ! shift down remaining data
  ibuf = ibuf - bl
  return
end subroutine flushbuffer


subroutine slicewrite(code)       ! add some bits (a 'slice') to output buffer
  integer, intent(in)  :: code

  if (nout == 0) then             ! initiate output buffer
    ibuf = 1
    skip = 0
    accum = 0
  end if
  nout = nout+1

  accum = accum + code * 2**skip  ! add bits at correct position in accum
  skip = skip + slen              ! slen is current slice length, in bits

  shiftout: do
    buf(ibuf:ibuf) = char(modulo(accum, 256))
    if (skip<8) then
      exit shiftout
    end if
    ibuf = ibuf+1                 ! last written buffer-byte is now permanent
    accum = accum / 256           ! remove that byte from accum
    skip = skip-8                 ! skip points to next bit to write in accum
  end do shiftout

  if (ibuf>255) then
    call flushbuffer()            ! won't write unfinished byte in buf[ibuf]
  end if
  return                          ! at most 255 bytes will be left in buffer
end subroutine slicewrite


subroutine InitTable()
  integer :: i

  do i=0,maxbase                  ! Start with defining the codes 0..maxbase
    endbyte(i) = char(i)          ! for one-pixel sequences (code=pixelvalue)
  end do                          ! Initially no multi-pixel codes exist
  follow(0:maxbase) = nocode
  next(0:maxbase) = nocode
  CC = maxbase+1                  ! `clear code-tabel', a control code
  EOI = maxbase+2                 ! `end of image', another control code
  ncod = CC + 2                   ! ncod = number of currently defined codes
  slen = blen + 1                 ! current number of bits to write one code
  curmaxcode = 2**slen - 1        ! currently the highest, until slen increases
  return
end subroutine InitTable


subroutine giflzw(Pixel)          ! routine for LZW coding
  integer, intent(in), dimension(:,:) :: Pixel
  integer                             :: i, j

  nout=0                          ! for counting the codes going out
  if (blen<2) then
    blen=2                        ! pixel code-length, 2 is minimum for GIF
  end if
  call integer_block_write (F_unit, blen, 1)

  maxbase = 2**blen - 1
  call InitTable()
  call slicewrite(CC)

  do j=1, ubound(Pixel,2)
   do i=1, ubound(Pixel,1)
    K = modulo(Pixel(i,j), maxbase+1)    ! take next byte, prevent overflow
    if (i==1 .and. j==1) then
      P = K                       ! first raster byte has one-byte code P
      cycle                       ! for the first byte no further action
    end if
                                  ! Now see if code exists for sequence [.P.]K
    child = follow(P)             ! [.P.]K is "string coded by P" followed by K
    childloop: do
      if ((child == nocode) .or. (ichar(endbyte(child)) == K)) then
        exit childloop
      end if
      child = next(child)
    end do childloop

    if (child /= nocode) then     ! If code for [.P.]K was found, store it in P
      P = child
    else                          ! If not: output P and create code for [.P.]K
      call slicewrite(P)
      if (ncod > maxcode) then    ! check if a new code can be added
        call slicewrite(CC)       ! If not: tell listener to clear table
        call InitTable()          ! and clear our own table
      else
        if (ncod > curmaxcode) then
          slen = slen+1                     ! New codes will be one bit longer
          curmaxcode = curmaxcode * 2 + 1   ! and more codes are possible
        end if
        endbyte(ncod) = char(K)   ! ncod is the new code for [.P.]K
        follow(ncod) = nocode
        next(ncod) = follow(P)    ! include ncod in the hashing list
        follow(P) = ncod          !     of codes with same start-sequence
        ncod = ncod+1
      end if
      P = K
    end if
   end do
  end do
  call slicewrite(P)              ! send the last code to buffer
  call slicewrite(EOI)            ! send 'end of image' to buffer
  call flushbuffer()              ! extra flush, including partial last byte

  return
end subroutine giflzw


subroutine writegif (FileName, Pixel, ColorMap, Transparent)
!
! Codes pixel-map with palette into GIF format. Optional transparent color
!
  character(len=*), intent(in)           :: FileName
  integer, intent(in), dimension(:,:)    :: Pixel
  type(color), intent(in), dimension(0:) :: ColorMap
  integer, intent(in), optional          :: Transparent
  
  character(len=256) :: s
  integer            :: InfoByte, nx, ny, Cblen, HasMap, maxincol,  &
                        maxgifcol, Background, i
  
  call open_for_write (F_unit, FileName)
  
  nx = ubound(Pixel, 1)
  ny = ubound(Pixel, 2)
  maxincol = size(ColorMap) - 1
  ! write(unit=*,fmt=*) "Nx, Ny, Ncol: ", nx,ny,maxincol+1
  
  do i=1,8                           ! find the bitsize, blen, for pixels
    blen = i
    maxgifcol = 2**blen - 1          ! Number of colors has to be power of 2 
    if (maxgifcol >= maxincol) then
      exit                           ! now blen and maxgifcol are correct
    end if                           ! only op to 256 colors can be 
  end do
  
  call char_block_write (F_unit, "GIF89a")         ! Signature
  
  !  Create information for screen descriptor
  Background = 0
  if (present(Transparent)) then
    Background = Transparent
  end if
  HasMap = 1
  Cblen = blen
  InfoByte = HasMap * 128 + (Cblen-1) * 16 + blen-1
  
  !  Write the screen descriptor
  call integer_block_write (F_unit, nx, 2)         ! write nx as 2-byte integer
  call integer_block_write (F_unit, ny, 2)
  call integer_block_write (F_unit, InfoByte, 1)
  call integer_block_write (F_unit, Background,1)  ! background as 1-byte
  call integer_block_write (F_unit, 0, 1)          ! dummy 0 required by GIF
  
  do i=0,maxgifcol                                 ! write global colormap
    call integer_block_write (F_unit, ColorMap(min(i,maxincol)) % r, 1)
    call integer_block_write (F_unit, ColorMap(min(i,maxincol)) % g, 1)
    call integer_block_write (F_unit, ColorMap(min(i,maxincol)) % b, 1)
  end do
  
  if (present(Transparent)) then
    write(unit=*,fmt=*) "Transparent color: ", Transparent
    s = "!" // char(249) // char(4) // char(1) // char(0) // char(0)  &
            // char(Transparent) // char(0)
    call char_block_write (F_unit, s(1:8))         ! GIF transparent extension
  end if
  
  call char_block_write (F_unit, ",")              ! Announce image
  
  !  Now create and write image descriptor
  HasMap = 0
  InfoByte = HasMap * 128 + blen-1                 ! add 64, if interlaced
  call integer_block_write (F_unit, 0, 2)          ! x_margin, not used
  call integer_block_write (F_unit, 0, 2)          ! y_margin, not used
  call integer_block_write (F_unit, nx, 2)         ! image dimensions
  call integer_block_write (F_unit, ny, 2)
  call integer_block_write (F_unit, InfoByte, 1)
  
  call giflzw (Pixel)                              ! now the raster data
  
  call integer_block_write (F_unit, 0, 1)          ! Terminating 0-block.
  call char_block_write (F_unit, ";")              ! Terminating ';' for GIF
  call close_block_io (F_unit)
  return
end subroutine writegif
  
end module gif_util