Fortran Wiki
read_gif

The module called gif contains a subroutine read_gif which can read GIF files of types Gif87a and Gif89 (and maybe others). The code comes from various authors, see comments below. This version was put together by Clive Page who has put it into the public domain.

! read_gif2.f90   cgp 2010 Aug 28
! Authors: Jos Bergervoet, Van Snyder, Maurizio Cremonesi, Clive Page, and others
! Original code from: http://it.geocities.com/butonoj/doc/gif-io/gifio.htm (now a dead link)
module gif
implicit none
public :: read_gif                     ! procedure, see below
private
! *****     private stuff     ******************************************
integer,private, parameter :: interlace = 6    ! index of bit indicating interlaced
integer,private, parameter :: max_lzw_bits = 12
integer,private, parameter :: use_local_colormap = 7 ! bit indicating to use local color map
integer, public, parameter :: max_colormap_size = 256
integer,private, save      :: lun                    ! logical unit number
logical,private            :: zero_data_block

type, public :: gif_screen_type
    integer :: aspect_ratio, background
    integer :: bit_pixel                 ! size of colormap
    integer :: color_resolution
    integer :: height, width             ! shape(image) = (/width,height/)
    integer :: color_map_size           ! size of local_colormap
    logical :: use_local_colormap       ! .true. if local color map, else global
end type gif_screen_type

type(gif_screen_type), public :: gif_screen

type, public :: gif89_type
    integer :: transparent
    integer :: delaytime
    integer :: inputflag
    integer :: disposal
end type gif89_type

type(gif89_type), public :: gif89
CONTAINS
! =========================================================================================
subroutine read_gif(filename, num_image, image, iostat, color_map, verbose)
! read the num_image'th gif image from filename into arrays image and color_map
character(len=*), intent(in) :: filename  ! input file
integer, intent(in)          :: num_image ! number of image required
integer, intent(out), allocatable :: image(:,:) ! Image data returned
integer, intent(out)         :: iostat    ! I/O error number, =0 if ok
real   , allocatable, intent(out) :: color_map(:,:) ! RGB for each level, range 0.0 to 1.0
logical, intent(in), optional :: verbose  ! .true.for verbose output
! -----     local variables     ------------------------------------
character(len=16) :: buf             ! input buffer
character (len=1):: c                       ! shorter input buffer
integer :: image_count               ! number of images processed so far
logical :: my_verbose
! -----     executable statements     ------------------------------
    zero_data_block = .false.
    gif89= gif89_type( -1, -1, -1, 0 )
    my_verbose = .false.
    if ( present(verbose) ) my_verbose = verbose
    call open_gif (filename, iostat, my_verbose, color_map )
    if (iostat /= 0) RETURN
    image_count = 0
    do ! forever
      call read_buf(c, iostat )
      if (iostat /= 0) then
        call io_error ( "reading file", iostat, filename )
        RETURN
      end if
      if ( c == ";" ) then ! gif image terminator
        if ( image_count < num_image ) then
          write (*,*) "only", image_count, "image(s) found in file"
          iostat = -1
        end if
        close ( unit=lun )
        RETURN
      end if
      if ( c == "!" ) then
   ! gif extension
        call do_extension (filename, iostat, my_verbose )
        if (iostat /= 0) RETURN
        CYCLE
      end if
      if ( c /= "," ) then
   ! not a valid start character
        write (*,*) "ignoring bogus character ", ichar(c)
        CYCLE
      end if
      image_count = image_count + 1
      if (image_count>num_image) RETURN
      call read_buf(buf(1:9), iostat )
      if (iostat /= 0) then
        call io_error("cannot read width/height", iostat, filename)
        RETURN
      end if
!
! If local colour map exists: read it
!
      gif_screen%use_local_colormap = btest(ichar(buf(9:9)),use_local_colormap)
      if ( gif_screen%use_local_colormap ) then
        gif_screen%color_map_size = 2**(modulo(ichar(buf(9:9)),8)+1)
        if(my_verbose) write(*,*)'read_gif error in local colour map, size=', &
                        gif_screen%color_map_size
        allocate(color_map(3,gif_screen%color_map_size))
        call read_colormap(color_map, iostat )
        if (iostat /= 0) then
          call io_error ( " error reading local color map", iostat, filename )
          RETURN
        end if
        call read_image(bcint2b(buf(5:6)), bcint2b(buf(7:8)), &
                         btest(ichar(buf(9:9)),interlace), image_count /= num_image, &
                         my_verbose, filename,  iostat, image)
        if (iostat /= 0) RETURN
      else
        call read_image(bcint2b(buf(5:6)), bcint2b(buf(7:8)), &
                         btest(ichar(buf(9:9)),interlace), image_count /= num_image, &
                         my_verbose, filename,  iostat, image )
        if (iostat /= 0) RETURN
      end if
    end do
    close(unit=lun)
    print *,'closed unit', lun, ' in read_gif'
  end subroutine read_gif

! *****  private module procedures     *********************************
! ================================================     bcint2b     =====
function bcint2b ( buf ) result (iresult)
! convert two bytes to an integer.  the bytes are in little-endian
! order -- the first one is the low-order byte, and the second is
! the high-order byte
character(len=*), intent(in) :: buf
integer :: iresult
iresult = 256*ichar(buf(2:2)) + ichar(buf(1:1))
end function bcint2b
! ===========================================     do_extension     =====
subroutine do_extension (filename, iostat, verbose )
character(len=*),intent(in) :: filename             ! in case it's needed in a message
integer, intent(out)        :: iostat
logical, intent(in)         :: verbose
!
    character(len=256), save :: buf      ! long input buffer
    character (len=1) :: c                       ! short input buffer
    integer :: countx                     ! length of a data block
    character(len=256) :: str            ! part of a message, if verbose
!
    call read_buf(c, iostat )
    if (iostat /= 0) then
      call io_error ( " error reading extension", iostat, filename )
      RETURN
    end if
    select case ( ichar(c) )
    case ( 1 )                           ! 0x01 -- plain text extension
      str = "plain text extension"
    case ( 249 )                         ! 0xf9 -- graphic control extension
      str = "graphic control extension"
      call get_data_block(buf, filename, countx, iostat )
      if (iostat /= 0)  then
         RETURN
      end if
      ! the gif89 structure isn't used.  why do we do this?
      gif89%disposal = modulo(ichar(buf(1:1))/4, 7)
      gif89%inputflag   = modulo(ichar(buf(1:1))/2, 1)
      gif89%delaytime   = bcint2b(buf(2:3))
      if ( modulo(ichar(buf(1:1)),2) /= 0 ) then
         gif89%transparent = ichar(buf(4:4))
      end if
      do
        call get_data_block(buf, filename, countx, iostat )
        if (iostat /= 0) then
          RETURN
        end if
        if ( countx == 0 ) then
          EXIT
        end if
      end do
    case ( 254 )                         ! 0xfe -- comment extension
      str = "comment extension"
      do
        call get_data_block(buf, filename, countx, iostat )
        if (iostat /= 0) then
          RETURN
        end if
        if ( countx == 0 ) then
           EXIT
        end if
        if (verbose) write (*,*) " gif comment: ", buf(:countx)
      end do
    case ( 255 )                         ! 0xff -- application extension
      str = "application extension"
    case default                         ! oops
      write (*,*) " unknown extension ", ichar(c), " label"
      str = buf
    end select
    if ( verbose ) write(*,*) 'read_gif: extension ', trim(str)
end subroutine do_extension
! ===============================================     get_code     =====
subroutine get_code ( result,code_size, flag, filename, iostat )
integer, intent(out) :: result
integer, intent(in) :: code_size
logical, intent(in) :: flag          ! first-time flag
character (len=*), intent(in) :: filename        ! in case it's needed in a message
integer, intent(out) :: iostat
!
    integer :: bint                      ! bit an integer (not logical)
    character(len=280), save :: buf      ! input buffer
    integer :: countx
    integer, save :: curbit
    logical, save :: done
    integer :: i, j, k
    integer, save :: lastbit
    integer, save :: last_byte
!
    if ( flag ) then
      curbit = 0
      lastbit = 0
      last_byte = 2
      buf(1:2) = "  " ! so it has a value the first time around
      done = .false.
      result = 0
      RETURN
    end if
    if ( curbit + code_size >= lastbit ) then
      if ( done ) then
        if ( curbit >= lastbit ) write (*,*) " ran off the end of my bits"
        result = -1
        RETURN
      end if
      buf(1:2) = buf(last_byte-1:last_byte)
      call get_data_block(buf(3:), filename, countx, iostat )
      if (iostat /= 0) then
        result = -1
        RETURN
      end if
      if ( countx == 0 ) done = .true.
      curbit = (curbit - lastbit) + 16
      last_byte = 2 + countx
      lastbit = last_byte * 8
    end if
    result = 0
    i = curbit / 8 + 1
    k = modulo(curbit, 8)
    do j = 0, code_size-1
      bint = 0
      if (btest(ichar(buf(i:i)), k)) bint = 1
      result = ior( result, ishft(bint,j) )
      curbit = curbit + 1
      k = k + 1
      if ( k == 8 ) then
        k = 0
        i = i + 1
      end if
    end do
  end subroutine get_code
! =========================================     get_data_block     =====
subroutine get_data_block (buf, filename, countx, iostat )
character(len=*), intent(out) :: buf
character(len=*), intent(in):: filename ! in case it's needed in a message
integer, intent(out) :: countx        ! size of data block
integer, intent(out) :: iostat
!
    character (len=1) :: c
    call read_buf(c, iostat )
    if (iostat /= 0) then
      call io_error ( " error in count for data block", iostat, filename )
      RETURN
    end if
    countx = ichar(c)
    zero_data_block = countx == 0
    if ( countx /= 0 ) then
      call read_buf(buf(1:countx), iostat )
      if (iostat /= 0) &
        call io_error (" error reading data block", iostat, filename )
    end if
  end subroutine get_data_block
! ======================================================================
subroutine get_lun ( lun )
integer, intent(out) :: lun    ! a free logical unit number
!
logical :: inuse, exists
!
do lun = 100, 6, -1
      inquire (unit=lun, opened=inuse, exist=exists )
      if (exists .and. .not. inuse) RETURN
end do
write(*,*) "get_lun: no free logical unit numbers"
lun = -1
end subroutine get_lun
! ======================================================================
subroutine io_error ( message, iostat, filename )
character(len=*), intent(in) :: message
integer, intent(in)          :: iostat
character(len=*), intent(in) :: filename
!
write (*,*) "read_gif error ", trim(message), ' in ', trim(filename), &
            " code =", iostat
end subroutine io_error
! ======================================================================
subroutine lzw_read_byte ( result, input_code_size, flag, filename, iostat )
integer, intent (out) :: result
integer, intent(in) :: input_code_size
logical, intent(in) :: flag          ! first-time flag
character(len=*), intent(in) :: filename             ! in case it's needed in a message
integer, intent(out) :: iostat
!
    character(len=260) :: buf
    integer, save :: clear_code
    integer :: code
    integer, save :: code_size
    integer :: countx
    integer, save :: end_code
    integer, save :: firstcode
    logical, save :: fresh = .false.
    integer :: i
    integer :: incode
    integer, save :: max_code, max_code_size
    integer, parameter :: max_max_code = 2**max_lzw_bits
    integer, parameter :: max_stack = 2*max_max_code
    integer, save :: oldcode
    integer, save :: set_code_size
    integer, dimension(0:1,0:max_max_code-1), save :: table
    integer,dimension(max_stack), save :: stack
    integer, save :: stack_ptr
    result = 0
    if ( flag ) then                     ! setup
        set_code_size = input_code_size
        clear_code = 2 ** set_code_size
        if ( set_code_size > max_lzw_bits ) then
           result= -1
           RETURN
         end if
         end_code = clear_code + 1
         code_size = set_code_size + 1
         max_code = clear_code + 2
         max_code_size = 2 * clear_code
         stack_ptr = 1
         table(0,:) = 0
         do i = 0, clear_code-1
            table(1,i) = i
         end do
         table(1,clear_code:) = 0
         call get_code(i, code_size, .true., filename, iostat )   ! initialize
         fresh = .true.
         RETURN
    end if
    if ( fresh ) then
      fresh = .false.
      do
         call get_code(oldcode, code_size, .false., filename, iostat )
         firstcode = oldcode
         if ( firstcode /= clear_code ) EXIT
      end do
      result = firstcode
      RETURN
    end if
    if ( stack_ptr > 1 ) then
      stack_ptr = stack_ptr - 1
      result = stack(stack_ptr)
      RETURN
    end if
    do
      call get_code(code, code_size, .false., filename, iostat )
      if ( code < 0 ) EXIT
      if ( code == clear_code ) then
        code_size = set_code_size + 1
        max_code = clear_code + 2
        max_code_size = 2 * clear_code
        stack_ptr = 1
        table(0,:) = 0
        do i = 0, clear_code-1
          table(1,i) = i
        end do
        table(1,clear_code:) = 0
        call get_code( oldcode, code_size, .false., filename, iostat )
        firstcode = oldcode
        result = firstcode
        RETURN
      end if
      if ( code == end_code ) then
        result = -2
        if ( zero_data_block ) RETURN
        do
          call get_data_block(buf, filename, countx, iostat )
          if (iostat /= 0) RETURN
          if ( countx <= 0 ) EXIT
        end do
        if ( countx /= 0 ) then
          write (unit=*, fmt="(a)") "missing eod in data stream in file"
          write (unit=*, fmt="(a)") trim(filename)
          write (unit=*, fmt="(a)") "(this is not unusual)"
        end if
        RETURN
      end if
      incode = code
      if ( code >= max_code ) then
        stack(stack_ptr) = firstcode
        stack_ptr = stack_ptr + 1
        code = oldcode
      end if
      do
        if ( code >= clear_code ) then
           stack(stack_ptr) = table(1,code)
           stack_ptr = stack_ptr + 1
           if ( code == table(0,code) ) then
             write (unit=*, fmt="(a,i6,a,i6)") "code =", code,", table(0,code) =", table(0,code)
             write (unit=*, fmt="(a)") "circular table entry in file"
             write (unit=*, fmt="(a)") trim(filename)
             write (unit=*, fmt="(a)") "this is a serious error."
             result = -2
             RETURN
           end if
           code = table(0,code)
        else
          EXIT
        end if
      end do
      firstcode = table(1,code)
      stack(stack_ptr) = firstcode
      stack_ptr = stack_ptr + 1
      code = max_code
      if ( code < max_max_code ) then
        table(0,code) = oldcode
        table(1,code) = firstcode
        max_code = max_code + 1
        if ( max_code >= max_code_size .and. max_code_size < max_max_code ) then
          max_code_size = max_code_size * 2
          code_size = code_size + 1
        end if
      end if
      oldcode = incode
      if ( stack_ptr > 1 ) then
        stack_ptr = stack_ptr - 1
        result = stack(stack_ptr)
        RETURN
      end if
    end do
    result = code
  end subroutine lzw_read_byte
! ===============================================     open_gif     =====
subroutine open_gif (filename, iostat, verbose, color_map)
! open a gif file, verify it's either gif87a or gif89a
! fill the gif_screen structure, including reading the color map if
! necessary.
! iostat > 0 is status from open or read, iostat = -1 means wrong format.
! a message will be printed if iostat /= 0.
character(len=*), intent(in) :: filename
integer, intent(out) :: iostat
logical, intent(in) :: verbose
real, allocatable, intent(out) :: color_map(:,:)
!
character(len=7) :: buf              ! input buffer
!
call get_lun ( lun )
if (lun<1) then
   iostat = -1
   RETURN
end if
if ( verbose ) write (unit=*, fmt="(a,a)") "opening ", trim(filename)
open(unit=lun, file=filename, access="stream", status="old", iostat=iostat)
if (iostat /= 0) then
    call io_error ( " failed to open", iostat, filename )
    RETURN
else
    end if
    call read_buf (buf(1:6), iostat )
    if (iostat /= 0) then
      call io_error ( " error reading 'magic number'", iostat, filename )
      RETURN
    end if
    if ( buf(1:6) /= "GIF87a" .and. buf(1:6) /= "GIF89a" ) then
      write (*,*) " invalid GIF format", buf(1:6), " in ", trim(filename),&
         " expected GIF87a or GIF89a"
      iostat = -1
      close ( unit=lun )
      RETURN
    end if
    call read_buf (buf(1:7), iostat )
    if (iostat /= 0) then
      RETURN
    end if
    gif_screen%width = bcint2b(buf(1:2))
    gif_screen%height = bcint2b(buf(3:4))
    gif_screen%bit_pixel = ishft(2,iand(ichar(buf(5:5)),7))
    gif_screen%color_resolution = iand(ishft(ichar(buf(5:5)),-3),14)+1
    gif_screen%background = ichar(buf(6:6))
    gif_screen%aspect_ratio = ichar(buf(7:7))
    if ( btest(ichar(buf(5:5)), use_local_colormap) ) then
        if(verbose) write(*,*) &
           'read_gif error in global colour map size', gif_screen%bit_pixel
        allocate(color_map(3,gif_screen%bit_pixel))
        call read_colormap(color_map, iostat )
        if (iostat /= 0) then
           call io_error ( "error reading global colormap", iostat, filename )
           RETURN
        end if
    end if
    if ( gif_screen%aspect_ratio /= 0 .and. gif_screen%aspect_ratio /= 49 ) then
      write (*,*) "read_gif warning: non-square pixels, ratio=", &
                 ( gif_screen%aspect_ratio + 15.0 ) / 64.0
    end if
end subroutine open_gif
! ===============================================     read_buf     =====
subroutine read_buf (buf, iostat )
! read the next len(buf) characters from the gif file opened by open_gif.
character(len=*), intent(out) :: buf
integer, intent(out) :: iostat   ! I/O status, =0 if no error
read(unit=lun, iostat=iostat) buf
end subroutine read_buf
! ==========================================     read_colormap     =====
subroutine read_colormap (colormap, iostat )
! read the colormap.
real, dimension(:), intent(out) :: colormap(:,:)  ! 1st dimension: red/green/blue
integer, intent(out) :: iostat
!
integer :: j
character :: triplet*3
!
do j = 1, size(colormap,2)
    call read_buf(triplet, iostat )
    if (iostat /= 0) then
        write(*,*) 'read_gif: error reading colormap at j=', j, iostat
        RETURN
    end if
    colormap(1,j) = ichar(triplet(1:1)) / 255.0
    colormap(2,j) = ichar(triplet(2:2)) / 255.0
    colormap(3,j) = ichar(triplet(3:3)) / 255.0
end do
end subroutine read_colormap
! =============================================     read_image     =====
subroutine read_image (length, height, interlace, ignore, &
                       verbose, filename, iostat, image)
integer, intent(in) :: length
integer, intent(in) :: height
logical, intent(in) :: interlace
logical, intent(in) :: ignore
character(len=*),intent(in) :: filename             ! so it can appear in messages
logical, intent(in) :: verbose
!    character (len=*),dimension(:,:), pointer :: image
integer, intent(out) :: iostat
integer, intent(out), allocatable :: image(:,:)
!
character (len=1) :: c              ! input buffer
integer :: pass                     ! pass number, for interlaced images
integer :: vbyte                    ! output from lzw_read_byte
integer :: xpos, ypos               ! coordinates of pixel
integer :: rslt
!
    call read_buf(c, iostat )
    if (iostat /= 0) then
      call io_error ( "error reading code size byte", iostat, filename )
      RETURN
    end if
    call lzw_read_byte( rslt, ichar(c), .true., filename, iostat )
    if ( rslt < 0 ) then
      call io_error ( "reading image prefix", iostat, filename )
      RETURN
    end if
    if ( ignore ) then                   ! skip an uninteresting image
      if ( verbose ) then
         write (unit=*, fmt="(a)") "skipping an image"
      end if
      call lzw_read_byte (rslt, ichar(c), .false., filename, iostat )
      do
         if ( rslt >= 0 ) then
            call lzw_read_byte (rslt, ichar(c), .false., filename, iostat )
         else
            EXIT
         end if
      end do
      RETURN
    end if
 !
    if(verbose) write(unit=*,fmt=*) "Image size:",length,height
    allocate ( image(length,height), stat=iostat )
 !
    if (iostat /= 0) then
      call io_error ( "while allocating image", iostat, filename )
      RETURN
    end if
    if ( verbose ) write (*,*) " reading", length," by", height, " GIF image from ", &
                   trim(filename), "  ", merge("interlaced", "          ", interlace)
    pass = 0
    xpos = 1
    ypos = 1
    do
      call lzw_read_byte (vbyte, ichar(c), .false., filename, iostat )
      if (vbyte < 0) EXIT
      image(xpos,ypos) = vbyte
      xpos = xpos + 1
      if ( xpos > length ) then
        xpos = 1
        if ( interlace ) then
          select case ( pass )
          case ( 0, 1 )
            ypos = ypos + 8
          case ( 2 )
            ypos = ypos + 4
          case ( 3 )
            ypos = ypos + 2
          end select
          if ( ypos > height ) then
            pass = pass + 1
            select case ( pass )
            case ( 1 )
              ypos = 5
            case ( 2 )
              ypos = 3
            case ( 3 )
              ypos = 2
            case default
              EXIT
            end select
          end if
        else
          ypos = ypos + 1
        end if
      end if
      if ( ypos > height ) EXIT
    end do
      call lzw_read_byte ( rslt,ichar(c), .false., filename, iostat )
    if ( rslt >= 0 ) then
      write (*,*) "read_gif: too much input data, ignoring extra..."
      do
        if ( rslt >= 0 ) then
          call lzw_read_byte ( rslt, ichar(c), .false., filename, iostat )
        else
          EXIT
        end if
      end do
    end if
  end subroutine read_image
end module gif