1C*WDDRIV -- PGPLOT XWD drivers
2C+
3      SUBROUTINE WDDRIV (IFUNC, RBUF, NBUF, CHR, LCHR, MODE)
4      INTEGER IFUNC, NBUF, LCHR, MODE
5      REAL    RBUF(*)
6      CHARACTER*(*) CHR
7*
8* PGPLOT driver for X Window Dump (XWD) files.
9*
10* Supported device: XWD format
11*
12* Device type codes: /WD or /VWD
13*
14* Default device name: pgplot.xwd.
15*
16* If you have more than one image to plot (i.e. use PGPAGE) with this
17* device, subsequent pages will be named: pgplot2.xwd, pgplot3.xwd,
18* etc, disrespective of the device name you specified.
19* You can however bypass this by specifying a device name including a
20* number sign (#), which will henceforth be replaced by the pagenumber.
21* Example: page#.xwd will produce files page1.xwd, page2.xwd, ...,
22* page234.xwd, etc.
23*
24* Default view surface dimensions are:
25* - WD   : 850 x 680 pixels (translates to 10.0 x  8.0 inch).
26* - VWD  : 680 x 850 pixels (translates to  8.0 x 10.0 inch).
27* with an assumed scale of 85 pixels/inch.
28* Default width and height can be overridden by specifying environment
29* variables
30* PGPLOT_WD_WIDTH  (default 850)
31* PGPLOT_WD_HEIGHT (default 680)
32*
33* Color capability:
34* Indices 0 to 255 are supported. Each of these indices can be assigned
35* one color. Default colors for indices 0 to 15 are implemented.
36*
37* Obtaining hardcopy: Use an XWD viewer (xwud) or converter.
38*=
39* 23-Jan-1995 - Steal GIDRIV.F code and bash appropriately [SCA].
40* 28-Dec-1995 - Prevent concurrent access [TJP].
41* 29-Apr-1996 - Use GRCTOI to decode environment variables [TJP].
42*-----------------------------------------------------------------------
43      CHARACTER*(*) LTYPE, PTYPE, DEFNAM
44      INTEGER DWD, DHT, BX, BY
45      PARAMETER (LTYPE=
46     1'WD    (X Window Dump file, landscape orientation)',
47     2 PTYPE=
48     3'VWD   (X Window Dump file, portrait orientation)')
49      PARAMETER (DEFNAM='pgplot.xwd')
50      PARAMETER (DWD=850, DHT=680)
51
52      REAL XRES, YRES
53      PARAMETER (XRES=85., YRES=XRES)
54C
55      INTEGER UNIT, IC, NPICT, MAXIDX, STATE
56      INTEGER CTABLE(3,0:255), CDEFLT(3,0:15)
57      INTEGER IER, I, L, LL, IX0, IY0, IX1, IY1, USERH, USERW, JUNK
58      INTEGER GRGMEM, GRFMEM, GROFIL, GRCFIL, GRCTOI
59      CHARACTER*80 MSG, INSTR, FILENM
60C
61C Note: for 64-bit operating systems, change the following
62C declaration to INTEGER*8:
63C
64      INTEGER*8 PIXMAP
65C
66      SAVE UNIT, IC, CTABLE, NPICT, MAXIDX, BX, BY, PIXMAP, FILENM
67      SAVE CDEFLT, STATE
68      DATA CDEFLT /000,000,000, 255,255,255, 255,000,000, 000,255,000,
69     1             000,000,255, 000,255,255, 255,000,255, 255,255,000,
70     2             255,128,000, 128,255,000, 000,255,128, 000,128,255,
71     3             128,000,255, 255,000,128, 085,085,085, 170,170,170/
72      DATA STATE /0/
73C-----------------------------------------------------------------------
74C
75      GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
76     1     110,120,130,140,150,160,170,180,190,200,
77     2     210,220,230,240,250,260,270,280,290), IFUNC
78  900 WRITE (MSG,'(I10)') IFUNC
79      CALL GRWARN('Unimplemented function in WD device driver:'
80     1    //MSG)
81      NBUF = -1
82      RETURN
83C
84C--- IFUNC = 1, Return device name -------------------------------------
85C
86   10 IF (MODE.EQ.1) THEN
87         CHR = LTYPE
88         LCHR = LEN(LTYPE)
89      ELSE IF (MODE.EQ.2) THEN
90         CHR = PTYPE
91         LCHR = LEN(PTYPE)
92      ELSE
93         CALL GRWARN('Requested MODE not implemented in WD driver')
94      END IF
95      RETURN
96C
97C--- IFUNC = 2, Return physical min and max for plot device, and range
98C               of color indices ---------------------------------------
99C     (Maximum size is set by XWD format to 2**16 - 1 pixels)
100   20 RBUF(1) = 0
101      RBUF(2) = 65535
102      RBUF(3) = 0
103      RBUF(4) = 65535
104      RBUF(5) = 0
105      RBUF(6) = 255
106      NBUF = 6
107      RETURN
108C
109C--- IFUNC = 3, Return device resolution -------------------------------
110C
111   30 RBUF(1) = XRES
112      RBUF(2) = YRES
113      RBUF(3) = 1
114      NBUF = 3
115      RETURN
116C
117C--- IFUNC = 4, Return misc device info --------------------------------
118C    (This device is Hardcopy, supports rectangle fill, pixel
119C     primitives, and query color rep.)
120C
121   40 CHR = 'HNNNNRPNYN'
122      LCHR = 10
123      RETURN
124C
125C--- IFUNC = 5, Return default file name -------------------------------
126C
127   50 CHR = DEFNAM
128      LCHR = LEN(DEFNAM)
129      RETURN
130C
131C--- IFUNC = 6, Return default physical size of plot -------------------
132C
133   60 RBUF(1) = 0
134      RBUF(2) = BX-1
135      RBUF(3) = 0
136      RBUF(4) = BY-1
137      NBUF = 4
138      RETURN
139C
140C--- IFUNC = 7, Return misc defaults -----------------------------------
141C
142   70 RBUF(1) = 1
143      NBUF=1
144      RETURN
145C
146C--- IFUNC = 8, Select plot --------------------------------------------
147C
148   80 CONTINUE
149      RETURN
150C
151C--- IFUNC = 9, Open workstation ---------------------------------------
152C
153   90 CONTINUE
154C     -- check for concurrent access
155      IF (STATE.EQ.1) THEN
156         CALL GRWARN('a PGPLOT XWD file is already open')
157         RBUF(1) = 0
158         RBUF(2) = 0
159         RETURN
160      END IF
161C     -- dimensions of plot buffer
162      USERW = 0
163      USERH = 0
164      CALL GRGENV('WD_WIDTH', INSTR, L)
165      LL = 1
166      IF (L.GT.0) USERW = GRCTOI(INSTR(:L),LL)
167      CALL GRGENV('WD_HEIGHT', INSTR, L)
168      LL = 1
169      IF (L.GT.0) USERH = GRCTOI(INSTR(:L),LL)
170      IF (MODE.EQ.1) THEN
171*     -- Landscape
172         BX = DWD
173         IF (USERW.GE.8) BX = USERW
174         BY = DHT
175         IF (USERH.GE.8) BY = USERH
176      ELSE
177*     -- Portrait
178         BX = DHT
179         IF (USERH.GE.8) BX = USERH
180         BY = DWD
181         IF (USERW.GE.8) BY = USERW
182      END IF
183      NPICT=1
184      MAXIDX=0
185*     -- Initialize color table
186      DO 95 I=0,15
187         CTABLE(1,I) = CDEFLT(1,I)
188         CTABLE(2,I) = CDEFLT(2,I)
189         CTABLE(3,I) = CDEFLT(3,I)
190 95   CONTINUE
191      DO 96 I=16,255
192         CTABLE(1,I) = 128
193         CTABLE(2,I) = 128
194         CTABLE(3,I) = 128
195 96   CONTINUE
196*
197      FILENM = CHR(:LCHR)
198      CALL GRWD05 (FILENM, NPICT, MSG)
199      UNIT = GROFIL (MSG)
200      RBUF(1) = UNIT
201      IF (UNIT.LT.0) THEN
202         CALL GRWARN('Cannot open output file for WD plot')
203         RBUF(2) = 0
204      ELSE
205         RBUF(2) = 1
206         STATE = 1
207      END IF
208      RETURN
209C
210C--- IFUNC=10, Close workstation ---------------------------------------
211C
212  100 CONTINUE
213      STATE = 0
214      RETURN
215C
216C--- IFUNC=11, Begin picture -------------------------------------------
217C
218  110 CONTINUE
219      BX = NINT(RBUF(1))+1
220      BY = NINT(RBUF(2))+1
221      IER = GRGMEM(BX*BY, PIXMAP)
222      IF (IER.NE.1) THEN
223         CALL GRGMSG(IER)
224         CALL GRWARN('Failed to allocate plot buffer.')
225         BX = 0
226         BY = 0
227         PIXMAP = 0
228      END IF
229C     -- initialize to zero (background color)
230      IF (PIXMAP.NE.0)
231     :     CALL GRWD03(1, 1, BX, BY, 0, BX, BY, %VAL(PIXMAP))
232      IF (NPICT.GT.1) THEN
233         CALL GRWD05 (FILENM, NPICT, MSG)
234         UNIT = GROFIL(MSG)
235         IF (UNIT.LT.0) THEN
236            CALL GRWARN('Cannot open output file for WD plot')
237         END IF
238      END IF
239      RETURN
240C
241C--- IFUNC=12, Draw line -----------------------------------------------
242C
243  120 CONTINUE
244      IX0=NINT(RBUF(1))+1
245      IX1=NINT(RBUF(3))+1
246      IY0=BY-NINT(RBUF(2))
247      IY1=BY-NINT(RBUF(4))
248      IF (PIXMAP.NE.0)
249     :     CALL GRWD01(IX0, IY0, IX1, IY1, IC, BX, BY, %VAL(PIXMAP))
250      RETURN
251C
252C--- IFUNC=13, Draw dot ------------------------------------------------
253C
254  130 CONTINUE
255      IX0=NINT(RBUF(1))+1
256      IY0=BY-NINT(RBUF(2))
257      IF (PIXMAP.NE.0)
258     :     CALL GRWD01(IX0, IY0, IX0, IY0, IC, BX, BY, %VAL(PIXMAP))
259      RETURN
260C
261C--- IFUNC=14, End picture ---------------------------------------------
262C
263  140 CONTINUE
264      IF (UNIT.GE.0) THEN
265         CALL GRWD06(UNIT, BX, BY, CTABLE, %VAL(PIXMAP), MAXIDX)
266         JUNK = GRCFIL(UNIT)
267      END IF
268      NPICT = NPICT+1
269      IER = GRFMEM(BX*BY, PIXMAP)
270      IF (IER.NE.1) THEN
271         CALL GRGMSG(IER)
272         CALL GRWARN('Failed to deallocate plot buffer.')
273      END IF
274      RETURN
275C
276C--- IFUNC=15, Select color index --------------------------------------
277C
278  150 CONTINUE
279      IC = RBUF(1)
280      MAXIDX = MAX(MAXIDX, IC)
281      RETURN
282C
283C--- IFUNC=16, Flush buffer. -------------------------------------------
284C    (Not used.)
285C
286  160 CONTINUE
287      RETURN
288C
289C--- IFUNC=17, Read cursor. --------------------------------------------
290C    (Not implemented: should not be called)
291C
292  170 CONTINUE
293      GOTO 900
294C
295C--- IFUNC=18, Erase alpha screen. -------------------------------------
296C    (Not implemented: no alpha screen)
297C
298  180 CONTINUE
299      RETURN
300C
301C--- IFUNC=19, Set line style. -----------------------------------------
302C    (Not implemented: should not be called)
303C
304  190 CONTINUE
305      GOTO 900
306C
307C--- IFUNC=20, Polygon fill. -------------------------------------------
308C    (Not implemented: should not be called)
309C
310  200 CONTINUE
311      GOTO 900
312C
313C--- IFUNC=21, Set color representation. -------------------------------
314C
315  210 CONTINUE
316      I = RBUF(1)
317      CTABLE(1, I) = NINT(RBUF(2)*255)
318      CTABLE(2, I) = NINT(RBUF(3)*255)
319      CTABLE(3, I) = NINT(RBUF(4)*255)
320      RETURN
321C
322C--- IFUNC=22, Set line width. -----------------------------------------
323C    (Not implemented: should not be called)
324C
325  220 CONTINUE
326      GOTO 900
327C
328C--- IFUNC=23, Escape --------------------------------------------------
329C    (Not implemented: ignored)
330C
331  230 CONTINUE
332      RETURN
333C
334C--- IFUNC=24, Rectangle fill ------------------------------------------
335C
336  240 CONTINUE
337      IX0=NINT(RBUF(1))+1
338      IX1=NINT(RBUF(3))+1
339      IY1=BY-NINT(RBUF(2))
340      IY0=BY-NINT(RBUF(4))
341      IF (PIXMAP.NE.0)
342     :     CALL GRWD03(IX0, IY0, IX1, IY1, IC, BX, BY, %VAL(PIXMAP))
343      RETURN
344C
345C--- IFUNC=25, Not implemented -----------------------------------------
346C
347  250 CONTINUE
348      RETURN
349C
350C--- IFUNC=26, Line of pixels ------------------------------------------
351C
352  260 CONTINUE
353      CALL GRWD04(NBUF, RBUF, BX, BY, %VAL(PIXMAP), MAXIDX)
354      RETURN
355C
356C--- IFUNC=27, Not implemented -----------------------------------------
357C
358  270 CONTINUE
359      RETURN
360C
361C--- IFUNC=28, Not implemented -----------------------------------------
362C
363  280 CONTINUE
364      RETURN
365C
366C--- IFUNC=29, Query color representation. -----------------------------
367C
368  290 CONTINUE
369      I = RBUF(1)
370      RBUF(2) = CTABLE(1,I)/255.0
371      RBUF(3) = CTABLE(2,I)/255.0
372      RBUF(4) = CTABLE(3,I)/255.0
373      NBUF = 4
374      RETURN
375C-----------------------------------------------------------------------
376      END
377
378**GRWD01 -- PGPLOT WD driver, draw line
379*+
380      SUBROUTINE GRWD01 (IX0, IY0, IX1, IY1, ICOL, BX, BY, PIXMAP)
381      INTEGER IX0, IY0, IX1, IY1
382      INTEGER ICOL, BX, BY
383      BYTE PIXMAP(BX,BY)
384*
385* Draw a straight-line segment from absolute pixel coordinates
386* (IX0, IY0) to (IX1, IY1).
387*
388* Arguments:
389*  ICOL            (input): Color index
390*  PIXMAP   (input/output): The image data buffer.
391*-----------------------------------------------------------------------
392      INTEGER IX, IY, IS
393      REAL    D
394      BYTE    VAL
395C
396      IF (ICOL .GT. 127) THEN
397         VAL = ICOL - 256
398      ELSE
399         VAL = ICOL
400      END IF
401C
402      IF (IX0.EQ.IX1 .AND. IY0.EQ.IY1) THEN
403         PIXMAP(IX0,IY0)=VAL
404      ELSE IF (ABS(IY1-IY0).GT.ABS(IX1-IX0)) THEN
405         D=(IX1-IX0)/REAL(IY1-IY0)
406         IS=1
407         IF (IY1.LT.IY0) IS=-1
408         DO 10 IY=IY0,IY1,IS
409            IX=NINT(IX0+(IY-IY0)*D)
410            PIXMAP(IX,IY)=VAL
411 10      CONTINUE
412      ELSE
413         D=(IY1-IY0)/REAL(IX1-IX0)
414         IS=1
415         IF (IX1.LT.IX0) IS=-1
416         DO 20 IX=IX0,IX1,IS
417            IY=NINT(IY0+(IX-IX0)*D)
418            PIXMAP(IX,IY)=VAL
419 20      CONTINUE
420      END IF
421      END
422
423**GRWD02 -- Store unsigned 16-bit integer in host independent format
424*+
425      SUBROUTINE GRWD02(I, ARR)
426      BYTE ARR(2)
427      INTEGER I, TMP
428*
429      TMP = MOD(I/256,256)
430      IF (TMP .GT. 127) THEN
431         ARR(1) = TMP - 256
432      ELSE
433         ARR(1) = TMP
434      END IF
435
436      TMP = MOD(I,256)
437      IF (TMP .GT. 127) THEN
438         ARR(2) = TMP - 256
439      ELSE
440         ARR(2) = TMP
441      END IF
442      END
443
444**GRWD03 -- PGPLOT WD driver, fill rectangle
445*+
446      SUBROUTINE GRWD03 (IX0, IY0, IX1, IY1, ICOL, BX, BY, PIXMAP)
447      INTEGER IX0, IY0, IX1, IY1
448      INTEGER ICOL, BX, BY
449      BYTE PIXMAP(BX,BY)
450*
451* Arguments:
452*  IX0, IY0        (input): Lower left corner.
453*  IX1, IY1        (input): Upper right corner.
454*  ICOL            (input): Color value.
455*  BX, BY          (input): dimensions of PIXMAP.
456*  PIXMAP   (input/output): The image data buffer.
457*-----------------------------------------------------------------------
458      INTEGER IX, IY
459      BYTE VAL
460*
461      IF (ICOL .GT. 127) THEN
462         VAL = ICOL - 256
463      ELSE
464         VAL = ICOL
465      END IF
466      DO 20 IY=IY0,IY1
467         DO 10 IX=IX0,IX1
468            PIXMAP(IX,IY) = VAL
469 10      CONTINUE
470 20   CONTINUE
471      END
472
473**GRWD04 -- PGPLOT WD driver, fill image line
474*+
475      SUBROUTINE GRWD04(NBUF,RBUF,BX,BY,PIXMAP,MAXIDX)
476      INTEGER I,J,NBUF,BX,BY,N,IC,MAXIDX
477      REAL RBUF(NBUF)
478      BYTE PIXMAP(BX,BY)
479*-
480      I = NINT(RBUF(1))+1
481      J = BY-NINT(RBUF(2))
482      DO 10 N=3,NBUF
483         IC=RBUF(N)
484         IF (IC .GT. 127) THEN
485            PIXMAP(I+N-3,J)=IC - 256
486         ELSE
487            PIXMAP(I+N-3,J)=IC
488         END IF
489         MAXIDX=MAX(MAXIDX,IC)
490 10   CONTINUE
491      END
492
493**GRWD05 -- Replace # in filename by picture number
494*+
495      SUBROUTINE GRWD05 (NAME1, NP, NAME2)
496      CHARACTER*(*) NAME1
497      CHARACTER*(*) NAME2
498      CHARACTER*80  TMP
499      INTEGER GRTRIM
500      INTEGER NP, IDX, L, LN
501
502      LN = GRTRIM(NAME1)
503      IDX = INDEX(NAME1,'#')
504      IF (IDX.GT.0) THEN
505C        -- if the supplied name contains a #-character, replace
506C           it with the page number
507         CALL GRFAO(NAME1, L, TMP, NP, 0, 0, 0)
508      ELSE IF (NP.EQ.1) THEN
509C        -- if this is the first page, use the supplied name
510         NAME2 = NAME1
511         RETURN
512      ELSE IF (LN+2.LE.LEN(NAME1)) THEN
513C        -- append an underscore and the page number to the supplied
514C           name
515         NAME1(LN+1:LN+2) = '_#'
516         CALL GRFAO(NAME1, L, TMP, NP, 0, 0, 0)
517      ELSE
518C        -- last resort: invent a new name
519         CALL GRFAO('pgplot#.xwd', L, TMP, NP, 0, 0, 0)
520      END IF
521      CALL GRWARN ('Writing new XWD image as: '//TMP(:L))
522      NAME2 = TMP(:L)
523      END
524
525**GRWD06 -- PGPLOT WD driver, write XWD image
526*+
527      SUBROUTINE GRWD06 (UNIT, BX, BY, CTABLE, PIXMAP, MAXIDX)
528      INTEGER UNIT, BX, BY, MAXIDX
529      INTEGER CTABLE(3,0:255)
530      BYTE PIXMAP(BX * BY)
531*
532* Write XWD image to UNIT.
533*
534* Arguments:
535* UNIT   (input): Output unit
536* BX,BY  (input): Image size
537* CTABLE (input): Color map
538* PIXMAP (input): Image data
539* MAXIDX (input): Maximum color index used.
540*--
541* 23-Jan-1995 - New routine [SCA]
542*-----------------------------------------------------------------------
543      BYTE    COLOR(12), HEAD(107)
544      INTEGER I, J, IER
545      INTEGER GRWFIL
546      DATA COLOR /0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 0/
547      DATA  HEAD / 0,   0,   0, 107,       0,   0,   0,   7,
548     1             0,   0,   0,   2,       0,   0,   0,   8,
549     2             0,   0,   0,   0,       0,   0,   0,   0,
550     3             0,   0,   0,   0,       0,   0,   0,   1,
551     4             0,   0,   0,   8,       0,   0,   0,   1,
552     5             0,   0,   0,   8,       0,   0,   0,   8,
553     6             0,   0,   0,   0,       0,   0,   0,   3,
554     7             0,   0,   0,   0,       0,   0,   0,   0,
555     8             0,   0,   0,   0,       0,   0,   0,   8,
556     9             0,   0,   1,   0,       0,   0,   0,   0,
557     A             0,   0,   0,   0,       0,   0,   0,   0,
558     B             0,   0,   0,   0,       0,   0,   0,   0,
559     C             0,   0,   0,   0,      80,  71,  80,  76,
560     D            79,  84,   0/
561*
562* Write image width into Header.
563*
564      CALL GRWD02 (BX, HEAD(19))
565      CALL GRWD02 (BX, HEAD(51))
566      CALL GRWD02 (BX, HEAD(83))
567*
568* Write image height into Header.
569*
570      CALL GRWD02 (BY, HEAD(23))
571      CALL GRWD02 (BY, HEAD(87))
572*
573* Write number of colors into Header.
574*
575      CALL GRWD02 (MAXIDX + 1, HEAD(79))
576*
577* Write Header.
578*
579      IER = GRWFIL (UNIT, 107, HEAD)
580      IF (IER .NE. 107) CALL GRWARN ('Error writing XWD header')
581*
582* Write out the color table.
583*
584      DO J = 0, MAXIDX
585         CALL GRWD02 (J, COLOR(3))
586         DO I = 1, 3
587            IF (CTABLE(I,J) .GT. 127) THEN
588               COLOR(3 + I * 2) = CTABLE(I,J) - 256
589            ELSE
590               COLOR(3 + I * 2) = CTABLE(I,J)
591            END IF
592            COLOR(4 + I * 2) = COLOR(3 + I * 2)
593         END DO
594         IER = GRWFIL (UNIT, 12, COLOR)
595      END DO
596*
597* Write out the bitmap.
598*
599      IER = GRWFIL (UNIT, BX * BY, PIXMAP)
600      END
601