!**************************************************************************** module gif_util ! Conversion of raster data to GIF format. ! ! Version 1.01, August 1999 ! Written by Jos Bergervoet ! 2008 Jan 28: Modified by Clive Page to use stream I/O, array as colourmap. ! 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 integer, parameter, private :: 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 !----------------------------------------------------------------------------- ! CHAR2 Converts the two least sig bytes of an integer to a 2-character string character(len=2) function char2(ival) integer, intent(in) :: ival char2 = achar(mod(ival,256)) // achar(mod(ival/256,256)) end function char2 !----------------------------------------------------------------------------- subroutine flushbuffer(F_unit) ! 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, intent(in) :: F_unit ! I/O unit to use 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 write(F_unit) CHAR(bl) 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 giflzw(F_unit, Pixel) ! routine for LZW coding integer, intent(in) :: F_unit 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 write(F_unit) CHAR(blen) maxbase = 2**blen - 1 call InitTable() call slicewrite(F_unit, 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(F_unit, P) if (ncod > maxcode) then ! check if a new code can be added call slicewrite(F_unit, 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(F_unit, P) ! send the last code to buffer call slicewrite(F_unit, EOI) ! send 'end of image' to buffer call flushbuffer(F_unit) ! extra flush, including partial last byte return end subroutine giflzw !----------------------------------------------------------------------------- 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 open_for_write(Fname, Funit) ! Creates a new Stream I/O file returning I/O unit used ! CGP 2009 Jan 28 character(len=*), intent(in) :: Fname integer, intent(out) :: Funit ! logical :: exists, open ! Get free I/O unit number do Funit = 90, 7, -1 inquire(unit=Funit, exist=exists, opened=open) if(exists .and. .not. open) EXIT end do if(Funit < 7) STOP 'open_for_write failed - no free I/O units' open (unit=Funit, file=Fname, access="STREAM", status="REPLACE") end subroutine open_for_write !----------------------------------------------------------------------------- subroutine slicewrite(F_unit, code) ! add some bits (a 'slice') to output buffer integer, intent(in) :: F_unit 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(F_unit) ! won't write unfinished byte in buf[ibuf] end if return ! at most 255 bytes will be left in buffer end subroutine slicewrite !----------------------------------------------------------------------------- subroutine writegif (FileName, Pixel, ColorMap, Transparent) ! ! Codes pixel-map with palette into GIF format. Optional transparent color ! 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 ! RGB 0:255 for colours 0:ncol integer, intent(in), optional :: Transparent ! Optional character(len=256) :: s integer :: InfoByte, nx, ny, Cblen, HasMap, maxincol, & maxgifcol, Background, i, F_unit call open_for_write (FileName, F_unit) nx = ubound(Pixel, 1) ny = ubound(Pixel, 2) maxincol = ubound(ColorMap,2) !! print *,'image size', nx, ny, ' colours', maxincol 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 write(F_unit) "GIF89a" ! 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 write(F_unit) char2(nx), char2(ny), CHAR(InfoByte), CHAR(Background), CHAR(0) do i=0,maxgifcol ! write global colormap write(F_unit) CHAR(colormap(1,min(i,maxincol))), & CHAR(colormap(2,min(i,maxincol))), & CHAR(colormap(3,min(i,maxincol))) 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) write(F_unit) s(1:8) ! GIF transparent extension end if write(F_unit) "," ! Announce image ! Now create and write image descriptor HasMap = 0 InfoByte = HasMap * 128 + blen-1 ! add 64, if interlaced ! x_margin, y_margin (not used), image dimensions write(F_unit) char2(0), char2(0), char2(nx), char2(ny), CHAR(InfoByte) call giflzw (F_unit, Pixel) ! now the raster data write(F_unit) CHAR(0), ';' ! Terminating 0-block ; for GIF close(unit=F_unit) return end subroutine writegif !----------------------------------------------------------------------------- end module gif_util !***************************************************************************** !*GIDRIV -- PGPLOT GIF drivers ! Code converted using TO_F90 by Alan Miller Date: 2009-01-26 Time: 23:50:47 ! Substantially updated gidriv.f using above module. Clive Page 2009 Jan 28 !+ MODULE gidriv_mod USE gif_util IMPLICIT NONE !PRIVATE !PUBLIC :: gidriv CONTAINS !======================================================================== !*GRGI01 -- PGPLOT GIF driver, draw line !+ SUBROUTINE grgi01 (ix0, iy0, ix1, iy1, icol, bx, by, pixmap) INTEGER, INTENT(IN) :: ix0, iy0, ix1, iy1 INTEGER, INTENT(IN) :: icol INTEGER, INTENT(IN) :: bx, by INTEGER, INTENT(INOUT) :: pixmap(bx,by) ! Draw a straight-line segment from absolute pixel coordinates ! (IX0, IY0) to (IX1, IY1). ! Arguments: ! ICOL (input): Color index ! PIXMAP (input/output): The image data buffer. ! INTEGER :: ix, iy, is REAL :: d ! CGP: more error-trapping below to check (ix,iy) always in valid range !! write(9,*) 'draw line', ix0, iy0, ix1, iy1, icol IF (ix0 == ix1 .AND. iy0 == iy1) THEN IF(ix0 > 0 .and. ix0 <= bx .AND. iy0 > 0 .and. iy0 <= by) & pixmap(ix0,iy0)=icol ELSE IF (ABS(iy1-iy0) > ABS(ix1-ix0)) THEN d= (ix1-ix0) / REAL(iy1-iy0) is=1 IF (iy1 < iy0) is=-1 DO iy=iy0,iy1,is ix=nint(ix0+(iy-iy0)*d) IF(ix > 0 .and. ix <= bx .and. iy > 0 .and. iy <= by) pixmap(ix,iy)=icol END DO ELSE d=(iy1-iy0)/REAL(ix1-ix0) is=1 IF (ix1 < ix0) is=-1 DO ix=ix0,ix1,is iy=nint(iy0+(ix-ix0)*d) IF(ix > 0 .and. ix <= bx .and. iy > 0 .and. iy <= by) pixmap(ix,iy)=icol END DO END IF END SUBROUTINE grgi01 !======================================================================== !*GRGI04 -- PGPLOT GIF driver, fill image line SUBROUTINE grgi04(nbuf,rbuf,bx,by,pixmap,maxidx) INTEGER, INTENT(IN) :: nbuf REAL, INTENT(IN) :: rbuf(nbuf) INTEGER, INTENT(IN) :: bx, by INTEGER, INTENT(INOUT) :: pixmap(bx,by) INTEGER, INTENT(INOUT) :: maxidx INTEGER :: i,j, n,ic !! write(9,*) 'fill image line', nbuf, rbuf(1:2), ' maxidx=', maxidx i = nint(rbuf(1))+1 j = nint(rbuf(2)) DO n=3,nbuf ic=rbuf(n) maxidx=MAX(maxidx,ic) pixmap(i+n-3,j)=ic END DO END SUBROUTINE grgi04 !======================================================================== !*GRGI10 -- Replace # in filename by picture number SUBROUTINE grgi10 (name1, np, name2) CHARACTER (LEN=*), INTENT(IN) :: name1 INTEGER, INTENT(IN) :: np CHARACTER (LEN=*), INTENT(OUT) :: name2 ! CGP: much updated to preserve .gif extension with picture number before it CHARACTER (LEN=10) :: tmp INTEGER :: idx ! write(tmp, '(i0)') np idx = INDEX(name1,'#') IF (idx > 0) THEN ! name contains a #-character, replace it with the page number name2 = name1(1:idx-1) // trim(tmp) // name1(idx+1:) ELSE IF (np == 1) THEN ! if this is the first page, use the supplied name name2 = name1 ELSE ! append an underscore and the page number to name before the dot idx = index(name1, '.', .true.) name2 = name1(1:idx-1) // "_" // trim(tmp) // name1(idx:) END IF CALL grwarn ('Writing new GIF image as: '//trim(name2)) END SUBROUTINE grgi10 END MODULE gidriv_mod SUBROUTINE gidriv (ifunc, rbuf, nbuf, chr, lchr, mode) use gidriv_mod INTEGER, INTENT(IN OUT) :: ifunc REAL, INTENT(OUT) :: rbuf(*) INTEGER, INTENT(OUT) :: nbuf CHARACTER (LEN=*), INTENT(OUT) :: chr INTEGER, INTENT(OUT) :: lchr INTEGER, INTENT(IN) :: mode ! PGPLOT driver for Graphics Interchange Format (GIF) files. !*********************************************************************** ! CAUTION * ! * ! The GIF specification incorporates the Lempel-Zev-Welch (LZW) * ! compression technology which is the subject of a patent awarded to * ! Unisys. Use of this technology, and in particular creation of GIF * ! format files using this PGPLOT device driver, may require a license * ! from Unisys. * !*********************************************************************** ! Supported device: GIF87a file format ! Device type codes: /GIF or /VGIF ! Default device name: pgplot.gif. ! If you have more than one image to plot (i.e. use PGPAGE) with this ! device, subsequent pages will be named: pgplot2.gif, pgplot3.gif, ! etc, disrespective of the device name you specified. ! You can however bypass this by specifying a device name including a ! number sign (#), which will henceforth be replaced by the pagenumber. ! Example: page#.gif will produce files page1.gif, page2.gif, ..., ! page234.gif, etc. ! Default view surface dimensions are: ! - GIF : 850 x 680 pixels (translates to 10.0 x 8.0 inch). ! - VGIF : 680 x 850 pixels (translates to 8.0 x 10.0 inch). ! with an assumed scale of 85 pixels/inch. ! Default width and height can be overridden by specifying environment ! variables ! PGPLOT_GIF_WIDTH (default 850) ! PGPLOT_GIF_HEIGHT (default 680) ! Color capability: ! Indices 0 to 255 are supported. Each of these indices can be assigned ! one color. Default colors for indices 0 to 15 are implemented. ! Obtaining hardcopy: Use a GIF viewer or converter. != ! 1-Aug-1994 - Created by Remko Scharroo ! 9-Aug-1994 - New scheme for line plotting ! 16-Aug-1994 - Provide multi-image plotting. ! 8-Sep-1994 - Add opcode 29 [TJP]. ! 5-Nov-1994 - Adjust size of bitmap if necessary [TJP]. ! 18-Jan-1995 - Attempt to prevent integer overflow on systems where ! BYTE is signed [TJP]. ! 28-Dec-1995 - prevent concurrent access [TJP]. ! 29-Apr-1996 - use GRCTOI to decode environment variables [TJP]. ! 7-Jul-2000 - Changed BYTE to INTEGER*2 [cgp] ! 28-Jan-2009 - Substantial re-write using Jos Bergervoet's GIF utilities !----------------------------------------------------------------------- INTEGER :: bx, by CHARACTER (LEN=*), PARAMETER :: ltype='GIF (Graphics Interchange Format file, landscape orientation)' CHARACTER (LEN=*), PARAMETER :: ptype='VGIF (Graphics Interchange Format file, portrait orientation)' CHARACTER (LEN=*), PARAMETER :: defnam='pgplot.gif' INTEGER, PARAMETER :: dwd=850 INTEGER, PARAMETER :: dht=680 REAL, PARAMETER :: xres=85. REAL, PARAMETER :: yres=xres INTEGER :: UNIT, ic, npict, maxidx, state INTEGER :: ctable(3,0:255), cdeflt(3,0:15) INTEGER :: ier, i, l, ll, ix0, iy0, ix1, iy1, userw, userh INTEGER :: grgmem, grfmem, grofil, grctoi CHARACTER (LEN=80) :: msg, instr, filenm, filename ! Note: for 64-bit operating systems, change the following ! declaration to INTEGER*8: !* !* Changes for NAG f95 compiler: make PIXMAP allocatable !* INTEGER, allocatable, SAVE :: pixmap(:,:) SAVE UNIT, ic, ctable, npict, maxidx, bx, by, filenm, filename SAVE cdeflt, state ! Interchanged colour definitions below so default is white background, black lines ! DATA cdeflt /000,000,000, 255,255,255, 255,000,000, 000,255,000, & DATA cdeflt /255,255,255, 000,000,000, 255,000,000, 000,255,000, & 000,000,255, 000,255,255, 255,000,255, 255,255,000, & 255,128,000, 128,255,000, 000,255,128, 000,128,255, & 128,000,255, 255,000,128, 085,085,085, 170,170,170/ DATA state /0/ ! SELECT CASE(ifunc) CASE(1) !--- IFUNC = 1, Return device name ------------------------------------- IF (mode == 1) THEN chr = ltype lchr = LEN(ltype) ELSE IF (mode == 2) THEN chr = ptype lchr = LEN(ptype) ELSE CALL grwarn('Requested MODE not implemented in GIF driver') END IF !--- IFUNC = 2, Return physical min and max for plot device, and range ! of color indices --------------------------------------- ! (Maximum size is set by GIF format to 2**16 pixels) CASE(2) rbuf(1) = 0 rbuf(2) = 65536 rbuf(3) = 0 rbuf(4) = 65536 rbuf(5) = 0 rbuf(6) = 255 nbuf = 6 !--- IFUNC = 3, Return device resolution ------------------------------- CASE(3) rbuf(1) = xres rbuf(2) = yres rbuf(3) = 1 nbuf = 3 !--- IFUNC = 4, Return misc device info -------------------------------- ! (This device is Hardcopy, supports rectangle fill, pixel ! primitives, and query color rep.) CASE(4) chr = 'HNNNNNPNYN' ! CGP: changed to disable rectangle fill lchr = 10 !--- IFUNC = 5, Return default file name ------------------------------- CASE(5) chr = defnam lchr = LEN(defnam) !--- IFUNC = 6, Return default physical size of plot ------------------- CASE(6) rbuf(1) = 0 rbuf(2) = bx-1 rbuf(3) = 0 rbuf(4) = by-1 nbuf = 4 !--- IFUNC = 7, Return misc defaults ----------------------------------- CASE(7) rbuf(1) = 1 nbuf=1 !--- IFUNC = 8, Select plot -------------------------------------------- CASE(8) CONTINUE !--- IFUNC = 9, Open workstation --------------------------------------- CASE(9) ! -- check for concurrent access IF (state == 1) THEN CALL grwarn('a PGPLOT GIF file is already open') rbuf(1) = 0 rbuf(2) = 0 RETURN END IF ! -- dimensions of plot buffer userw = 0 userh = 0 CALL grgenv('GIF_WIDTH', instr, l) ll = 1 IF (l > 0) userw = grctoi(instr(:l),ll) CALL grgenv('GIF_HEIGHT', instr, l) ll = 1 IF (l > 0) userh = grctoi(instr(:l),ll) IF (mode == 1) THEN !-- Landscape bx = dwd IF (userw >= 8) bx = userw by = dht IF (userh >= 8) by = userh ELSE !-- Portrait bx = dht IF (userh >= 8) bx = userh by = dwd IF (userw >= 8) by = userw END IF npict=1 maxidx=0 !-- Initialize color table ctable(1:3,0:15) = cdeflt(1:3,0:15) ctable(1:3,16:255) = 128 filenm = chr(:lchr) CALL grgi10 (filenm, npict, filename) ! UNIT = grofil (msg) ! Now a module procedure using Stream I/O rbuf(1) = UNIT rbuf(2) = 1 state = 1 !--- IFUNC=10, Close workstation --------------------------------------- CASE(10) state = 0 !--- IFUNC=11, Begin picture ------------------------------------------- CASE(11) bx = nint(rbuf(1))+1 by = nint(rbuf(2))+1 allocate(pixmap(bx,by)) !-- initialize to zero (background color) pixmap = 0 IF (npict > 1) THEN CALL grgi10 (filenm, npict, filename) UNIT = grofil(msg) END IF !--- IFUNC=12, Draw line ----------------------------------------------- CASE(12) ix0=nint(rbuf(1))+1 ix1=nint(rbuf(3))+1 iy0=nint(rbuf(2)) iy1=nint(rbuf(4)) CALL grgi01(ix0, iy0, ix1, iy1, ic, bx, by, pixmap) !--- IFUNC=13, Draw dot ------------------------------------------------ CASE(13) ix0=nint(rbuf(1))+1 iy0=nint(rbuf(2)) CALL grgi01(ix0, iy0, ix0, iy0, ic, bx, by, pixmap) !--- IFUNC=14, End picture --------------------------------------------- CASE(14) if(state == 1) then ! write(9,*) 'writegif: ', trim(filename) pixmap = pixmap(:,by:1:-1) call writegif(filename, pixmap, ctable) ! following line ok with g95, failed with gfortran ! call writegif(filename, pixmap(:,by:1:-1), ctable) end if ! state = 0 npict = npict+1 deallocate(pixmap) !--- IFUNC=15, Select color index -------------------------------------- CASE(15) ic = rbuf(1) maxidx = MAX(maxidx, ic) !--- IFUNC=16, Flush buffer. ------------------------------------------- ! (Not used.) CASE(16) CONTINUE !--- IFUNC=17, Read cursor. -------------------------------------------- ! (Not implemented: should not be called) !--- IFUNC=18, Erase alpha screen. ------------------------------------- ! (Not implemented: no alpha screen) CASE(18) !--- IFUNC=19, Set line style. ----------------------------------------- ! (Not implemented: should not be called) !--- IFUNC=20, Polygon fill. ------------------------------------------- ! (Not implemented: should not be called) !--- IFUNC=21, Set color representation. ------------------------------- CASE(21) i = rbuf(1) ctable(1, i) = nint(rbuf(2)*255) ctable(2, i) = nint(rbuf(3)*255) ctable(3, i) = nint(rbuf(4)*255) !--- IFUNC=22, Set line width. ----------------------------------------- ! (Not implemented: should not be called) !--- IFUNC=23, Escape -------------------------------------------------- ! (Not implemented: ignored) CASE(23) CONTINUE !--- IFUNC=24, Rectangle fill (not implemented) ------------------------- CASE(24) !--- IFUNC=25, Not implemented ----------------------------------------- CASE(25) !--- IFUNC=26, Line of pixels ------------------------------------------ CASE(26) CALL grgi04(nbuf, rbuf, bx, by, pixmap, maxidx) !--- IFUNC=27, Not implemented ----------------------------------------- CASE(27) CONTINUE !--- IFUNC=28, Not implemented ----------------------------------------- CASE(28) CONTINUE !--- IFUNC=29, Query color representation. ----------------------------- CASE(29) i = rbuf(1) rbuf(2) = ctable(1,i)/255.0 rbuf(3) = ctable(2,i)/255.0 rbuf(4) = ctable(3,i)/255.0 nbuf = 4 CASE DEFAULT WRITE (msg,'(I10)') ifunc CALL grwarn('Unimplemented function in GIF device driver:' //msg) nbuf = -1 END SELECT RETURN END SUBROUTINE gidriv