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