| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| character(len=*), | intent(in) | :: | filename |
file to create or replace |
||
| integer, | intent(in), | dimension(:,:,:) | :: | pixel |
pixel values [0 to ncol] |
|
| integer, | intent(in), | dimension(:,0:) | :: | colormap |
[r,g,b (0:255)] , [0:ncol] colors |
|
| integer, | intent(in), | optional | :: | transparent |
transparent color |
|
| integer, | intent(in), | optional | :: | delay |
delay time [1/100 of seconds] |
subroutine write_animated_gif(filename,pixel,colormap,transparent,delay)
character(len=*),intent(in) :: filename !! file to create or replace
integer,intent(in),dimension(:,:,:) :: pixel !! pixel values [0 to ncol]
integer,intent(in),dimension(:,0:) :: colormap !! [r,g,b (0:255)] , [0:ncol] colors
integer,intent(in),optional :: transparent !! transparent color
integer,intent(in),optional :: delay !! delay time [1/100 of seconds]
integer,parameter :: bufend=260
character(len=bufend) :: buf
integer :: ibuf ! output buffer vars
integer,parameter :: maxcode = 4095
integer,parameter :: nocode = maxcode+1 !! definitions for lzw
! define lzw code tables for hashing:
!
! 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
!
character(len=1),dimension(0:maxcode+1) :: endbyte
integer,dimension(0:maxcode) :: follow, next
integer :: ncod, curmaxcode, eoi, cc, p, k, child, &
maxbase, skip, slen, blen, accum, nout
integer :: infobyte,nx,ny,cblen,hasmap,maxincol,istat,&
maxgifcol,background,i,iunit,iframe,n,dt
character(len=1),dimension(2) :: t
!delay time:
if (present(delay)) then
dt = delay
else
dt = 1
end if
!transparency info:
if (present(transparent)) then
t(1) = char(1) !Reserved+Disposal Method+User Input Flag+Transparent Color Flag
t(2) = char(transparent)
else
t(1) = char(0)
t(2) = char(0)
end if
open( newunit=iunit,&
file=trim(filename),&
access='STREAM',&
status='REPLACE',&
iostat=istat)
if (istat==0) then
n = size(pixel,1) !number of images
nx = ubound(pixel, 2)
ny = ubound(pixel, 3)
maxincol = ubound(colormap,2)
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) exit ! now blen and maxgifcol are correct
! [only up to 256 colors]
end do
!------------
! GIF Header
!------------
write(iunit) 'GIF89a'
! create information for screen descriptor
if (present(transparent)) then
background = transparent
else
background = 0
end if
hasmap = 1
cblen = blen
infobyte = hasmap * 128 + (cblen-1) * 16 + blen-1
! write the screen descriptor
write(iunit) char2(nx),& ! logical screen width
char2(ny),& ! logical screen height
char(infobyte),& ! screen and color map information
char(background),& ! background color index
char(0) ! pixel aspect ratio
! write global colormap
do i=0,maxgifcol
write(iunit) char(colormap(1,min(i,maxincol))), &
char(colormap(2,min(i,maxincol))), &
char(colormap(3,min(i,maxincol)))
end do
if (n>1) then !it is an animated gif
!-----------------------------
! Application Extension Block
!-----------------------------
! See: http://odur.let.rug.nl/kleiweg/gif/netscape.html
write(iunit) '!',& ! Extension Introducer (0x21)
char(255),& ! GIF Extension code
char(11),& ! Length of Application Block
'NETSCAPE',& ! Application Identifier
'2.0',& ! Application Authentication Code
char(3),& ! Length of Data Sub-Block
char(1),& ! 1 (0x01)
char(0),& ! number of loop iterations
char(0),& ! Data Sub-Block Terminator
char(0) ! Block Terminator (0x00)
end if
!each frame of the animated gif:
do iframe = 1,n
!---------------------------------
! Graphic Control Extension Block
!---------------------------------
write(iunit) '!',& ! Extension Introducer (0x21)
char(249),& ! Graphic Control Label (0xF9)
char(4),& ! Block Size (0x04)
t(1),& !
char2(dt),& ! Delay Time
t(2),& ! Transparent Color Index
char(0) ! Block Terminator (0x00)
!-------------
! Image Block
!-------------
! now create and write image descriptor
hasmap = 0
infobyte = hasmap * 128 + blen-1 ! add 64, if interlaced
write(iunit) ',',& ! Image Separator (0x2C)
char2(0),& ! Image Left Position
char2(0),& ! Image Top Position
char2(nx),& ! Image Width
char2(ny),& ! Image Height
char(infobyte) ! Image and Color Table Data Information
call giflzw(iunit,pixel(iframe,:,:)) ! now the raster data
write(iunit) char(0) ! Block Terminator (0x00)
end do
!---------
! Trailer
!---------
write(iunit) ';'
else
write(*,*) 'Error opening :'//trim(filename)
end if
!close the gif file:
close(unit=iunit,iostat=istat)
contains
!-----------------------------------------------------------------------------------------------------------------------------------
!>
! Convert the two least sig bytes of an integer to a 2-character string
function char2(ival) result(c)
integer, intent(in) :: ival
character(len=2) :: c
c = achar(mod(ival,256)) // achar(mod(ival/256,256))
end function char2
!-----------------------------------------------------------------------------------------------------------------------------------
!>
! 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.
subroutine flushbuffer(iunit)
integer, intent(in) :: iunit !! i/o unit to use
integer :: bl !! number of bytes to write (to be determined)
if (ibuf > 255) then ! we will write buf[1..255]
bl = 255
else if (skip /= 0) then ! buf[ibuf] is partially used, write buf[1..ibuf]
bl = ibuf
else if (ibuf > 1) then ! write buf[1..ibuf-1], there is no partial byte
bl = ibuf-1
else ! nothing to write
return
end if
write(iunit) char(bl)
write(iunit) buf(1:bl)
buf(1:ibuf-bl) = buf(bl+1:ibuf) ! shift down remaining data
ibuf = ibuf - bl
end subroutine flushbuffer
!-----------------------------------------------------------------------------------------------------------------------------------
!>
! routine for LZW coding
subroutine giflzw(iunit, pixel)
integer, intent(in) :: iunit
integer, intent(in), dimension(:,:) :: pixel
integer :: i
integer :: 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
write(iunit) char(blen)
maxbase = 2**blen - 1
call inittable()
call slicewrite(iunit, 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(iunit, p)
if (ncod > maxcode) then ! check if a new code can be added
call slicewrite(iunit, 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(iunit, p) ! send the last code to buffer
call slicewrite(iunit, eoi) ! send 'end of image' to buffer
call flushbuffer(iunit) ! extra flush, including partial last byte
end subroutine giflzw
!-----------------------------------------------------------------------------------------------------------------------------------
!>
! Initialize table.
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
end subroutine inittable
!-----------------------------------------------------------------------------------------------------------------------------------
!>
! add some bits (a 'slice') to output buffer
subroutine slicewrite(iunit, code)
integer, intent(in) :: iunit
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) exit shiftout
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(iunit) ! won't write unfinished byte in buf[ibuf]
end if
! at most 255 bytes will be left in buffer
end subroutine slicewrite
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine write_animated_gif