1C*CCDRIV -- PGPLOT DEC LJ250 Color Companion driver 2C+ 3 SUBROUTINE CCDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) 4 IMPLICIT NONE 5 INTEGER IFUNC, NBUF, LCHR 6 REAL RBUF(*) 7 CHARACTER*(*) CHR 8C 9C PGPLOT driver for DEC LJ250 Color Companion device. 10C 11C Version 1.0 - 1989 Jun 04 - S. C. Allendorf 12C======================================================================= 13C 14C Supported device: DEC LJ250 Color Companion printer. 15C 16C Device type code: /CCP (portrait) or /CCL (landscape). 17C 18C Default device name: PGPLOT.CCPLT. 19C 20C Default view surface dimensions: 8.0 inches by 10.5 inches. 21C 22C Resolution: 90 dots/inch. 23C 24C Color capability: Color indices 0-15 are supported. It is not (yet) 25C possible to change color representation. 26C 27C Input capability: None. 28C 29C File format: DEC color sixel format. 30C 31C Obtaining hardcopy: Use the VMS PRINT command. 32C----------------------------------------------------------------------- 33C 34C To choose portrait mode, you must execute a DCL command of the 35C following form before executing your program: 36C 37C $ DEFINE PGPLOT_CC_MODE PORTRAIT 38C----------------------------------------------------------------------- 39 CHARACTER*(*) TYPE 40 PARAMETER (TYPE='CC (DEC LJ250 Color Companion printer)') 41 BYTE CTAB(3, 256), FF 42 LOGICAL HIRES, INIT, LANDSCAPE 43 INTEGER*4 BUFFER, BX, BY, I, IC, IER, GRFMEM, GRGMEM 44 INTEGER*4 LUN, MAXCOL, NPICT 45 REAL*4 XBUF(4) 46 CHARACTER DEFNAM*12, MODE*20, MSG*10 47 PARAMETER (FF = 12) 48 PARAMETER (DEFNAM = 'PGPLOT.CCPLT') 49 DATA INIT /.TRUE./ 50 DATA CTAB /100, 100, 100, 0, 0, 0, 100, 0, 0, 51 1 0, 100, 0, 0, 0, 100, 0, 100, 100, 52 2 100, 0, 100, 100, 100, 0, 100, 50, 0, 53 3 50, 100, 0, 0, 100, 50, 0, 50, 100, 54 4 50, 0, 100, 100, 0, 50, 33, 33, 33, 55 5 67, 67, 67, 720 * 0/ 56C----------------------------------------------------------------------- 57C First time, do some one-time 58C initialization. 59 IF (INIT) THEN 60C Make sure we only do this once. 61 INIT = .FALSE. 62C Initialize the maximum color 63C index currently used. 64 MAXCOL = 0 65C The default is low resolution, 66C landscape orientation. 67 LANDSCAPE = .TRUE. 68 HIRES = .FALSE. 69C Select mode based on logical. 70 CALL GRGENV ('CC_MODE', MODE, I) 71 IF (MODE(1:1) .EQ. 'P') LANDSCAPE = .FALSE. 72 IF (MODE(2:2) .EQ. 'H') HIRES = .TRUE. 73 END IF 74C Branch on opcode. 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), IFUNC 78C Signal an error. 79 900 WRITE (MSG, '(I10)') IFUNC 80 CALL GRWARN ('Unimplemented function in LJ250 device driver:' 81 1 // MSG) 82 NBUF = -1 83 RETURN 84C 85C--- IFUNC = 1, Return device name ------------------------------------- 86C 87 10 CONTINUE 88 CHR = TYPE 89 NBUF = 0 90 LCHR = LEN(TYPE) 91 RETURN 92C 93C--- IFUNC = 2, Return physical min and max for plot device, and range 94C of color indices --------------------------------------- 95C 96 20 CONTINUE 97 RBUF(1) = 0.0 98 IF (HIRES .AND. LANDSCAPE) RBUF(2) = 1889.0 99 IF (HIRES .AND. .NOT. LANDSCAPE) RBUF(2) = 1439.0 100 IF (.NOT. HIRES .AND. LANDSCAPE) RBUF(2) = 944.0 101 IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(2) = 719.0 102 RBUF(3) = 0.0 103 IF (HIRES .AND. LANDSCAPE) RBUF(4) = 1439.0 104 IF (HIRES .AND. .NOT. LANDSCAPE) RBUF(4) = 1889.0 105 IF (.NOT. HIRES .AND. LANDSCAPE) RBUF(4) = 719.0 106 IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(4) = 944.0 107 RBUF(5) = 0.0 108 IF (HIRES) THEN 109 RBUF(6) = 7.0 110 ELSE 111 RBUF(6) = 255.0 112 END IF 113 NBUF = 6 114 LCHR = 0 115 RETURN 116C 117C--- IFUNC = 3, Return device resolution ------------------------------- 118C 119 30 CONTINUE 120 IF (HIRES) THEN 121 RBUF(1) = 180.0 122 ELSE 123 RBUF(1) = 90.0 124 END IF 125 RBUF(2) = RBUF(1) 126 RBUF(3) = 1.0 127 NBUF = 3 128 LCHR = 0 129 RETURN 130C 131C--- IFUNC = 4, Return misc device info -------------------------------- 132C (This device is Hardcopy, No cursor, No dashed lines, No area fill, 133C no thick lines) 134C 135 40 CONTINUE 136 CHR = 'HNNNNNNNNN' 137 NBUF = 0 138 LCHR = 10 139 RETURN 140C 141C--- IFUNC = 5, Return default file name ------------------------------- 142C 143 50 CONTINUE 144 CHR = DEFNAM 145 NBUF = 0 146 LCHR = LEN(DEFNAM) 147 RETURN 148C 149C--- IFUNC = 6, Return default physical size of plot ------------------- 150C 151 60 CONTINUE 152 RBUF(1) = 0.0 153 IF (HIRES .AND. LANDSCAPE) RBUF(2) = 1889.0 154 IF (HIRES .AND. .NOT. LANDSCAPE) RBUF(2) = 1439.0 155 IF (.NOT. HIRES .AND. LANDSCAPE) RBUF(2) = 944.0 156 IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(2) = 719.0 157 RBUF(3) = 0.0 158 IF (HIRES .AND. LANDSCAPE) RBUF(4) = 1439.0 159 IF (HIRES .AND. .NOT. LANDSCAPE) RBUF(4) = 1889.0 160 IF (.NOT. HIRES .AND. LANDSCAPE) RBUF(4) = 719.0 161 IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(4) = 944.0 162 NBUF = 4 163 LCHR = 0 164 RETURN 165C 166C--- IFUNC = 7, Return misc defaults ----------------------------------- 167C 168 70 CONTINUE 169 RBUF(1) = 1.0 170 NBUF = 1 171 LCHR = 0 172 RETURN 173C 174C--- IFUNC = 8, Select plot -------------------------------------------- 175C 176 80 CONTINUE 177 RETURN 178C 179C--- IFUNC = 9, Open workstation --------------------------------------- 180C 181 90 CONTINUE 182C Assume success. 183 RBUF(2) = 1.0 184C Obtain a logical unit number. 185 CALL GRGLUN (LUN) 186C Check for an error. 187 IF (LUN .EQ. -1) THEN 188 CALL GRWARN ('Cannot allocate a logical unit.') 189 RBUF(2) = 0 190 RETURN 191 ELSE 192 RBUF(1) = LUN 193 END IF 194C Open the output file. 195 OPEN (UNIT = LUN, FILE = CHR(:LCHR), CARRIAGECONTROL = 'NONE', 196 1 DEFAULTFILE = DEFNAM, STATUS = 'NEW', 197 2 RECL = 362, FORM = 'UNFORMATTED', RECORDTYPE = 'VARIABLE', 198 3 IOSTAT = IER) 199C Check for an error and cleanup if 200C one occurred. 201 IF (IER .NE. 0) THEN 202 CALL GRWARN ('Cannot open output file for LJ250 plot: ' // 203 1 CHR(:LCHR)) 204 RBUF(2) = 0 205 CALL GRFLUN (LUN) 206 RETURN 207 ELSE 208C Get the full file specification 209C and calculate the length of the 210C string 211 INQUIRE (UNIT = LUN, NAME = CHR) 212 LCHR = LEN (CHR) 213 91 IF (CHR (LCHR:LCHR) .EQ. ' ') THEN 214 LCHR = LCHR - 1 215 GOTO 91 216 END IF 217 END IF 218C Initialize the page counter. 219 NPICT = 0 220 RETURN 221C 222C--- IFUNC = 10, Close workstation ------------------------------------- 223C 224 100 CONTINUE 225C Close the file. 226 CLOSE (LUN, STATUS = 'KEEP') 227C Deallocate the logical unit. 228 CALL GRFLUN (LUN) 229C 230 RETURN 231C 232C--- IFUNC = 11, Begin picture ----------------------------------------- 233C 234 110 CONTINUE 235C Calculate the dimensions of the 236C plot buffer. 237 IF (LANDSCAPE) THEN 238 XBUF(1) = RBUF(2) 239 XBUF(2) = RBUF(1) 240 ELSE 241 XBUF(1) = RBUF(1) 242 XBUF(2) = RBUF(2) 243 END IF 244 BX = INT (XBUF(1)) + 1 245 BY = (INT (XBUF(2)) / 6 + 1) * 6 246C Allocate a plot buffer. 247 IER = GRGMEM (BX * BY, BUFFER) 248C Check for error and clean up 249C if one was found. 250 IF (IER .NE. 1) THEN 251 CALL GRGMSG (IER) 252 CALL GRQUIT ('Failed to allocate a plot buffer.') 253 END IF 254C Increment the page number. 255 NPICT = NPICT + 1 256C Eject the page from the printer. 257 IF (NPICT .GT. 1) WRITE (LUN) FF 258C Zero out the plot buffer. 259 CALL GRCC04 (BX * BY, %VAL(BUFFER)) 260 RETURN 261C 262C--- IFUNC = 12, Draw line --------------------------------------------- 263C 264 120 CONTINUE 265C Apply any needed tranformation. 266 IF (LANDSCAPE) THEN 267 XBUF(1) = RBUF(2) 268 XBUF(2) = (BY - 1) - RBUF(1) 269 XBUF(3) = RBUF(4) 270 XBUF(4) = (BY - 1) - RBUF(3) 271 ELSE 272 XBUF(1) = RBUF(1) 273 XBUF(2) = RBUF(2) 274 XBUF(3) = RBUF(3) 275 XBUF(4) = RBUF(4) 276 END IF 277C Draw the point into the bitmap. 278 CALL GRCC00 (1, XBUF, IC, BX, BY, %VAL (BUFFER)) 279 RETURN 280C 281C--- IFUNC = 13, Draw dot ---------------------------------------------- 282C 283 130 CONTINUE 284C Apply any needed tranformation. 285 IF (LANDSCAPE) THEN 286 XBUF(1) = RBUF(2) 287 XBUF(2) = (BY - 1) - RBUF(1) 288 ELSE 289 XBUF(1) = RBUF(1) 290 XBUF(2) = RBUF(2) 291 END IF 292C Draw the point into the bitmap. 293 CALL GRCC00 (0, XBUF, IC, BX, BY, %VAL(BUFFER)) 294 RETURN 295C 296C--- IFUNC = 14, End picture ------------------------------------------- 297C 298 140 CONTINUE 299C Write out the bitmap. 300 CALL GRCC01 (LUN, BX, BY, %VAL (BUFFER), MAXCOL, HIRES, CTAB) 301C Deallocate the plot buffer. 302 IER = GRFMEM (BX * BY, BUFFER) 303C Check for an error. 304 IF (IER .NE. 1) THEN 305 CALL GRGMSG (IER) 306 CALL GRWARN ('Failed to deallocate plot buffer.') 307 END IF 308 RETURN 309C 310C--- IFUNC = 15, Select color index ------------------------------------ 311C 312 150 CONTINUE 313C Save the requested color index. 314 IC = RBUF(1) 315 MAXCOL = MAX (IC, MAXCOL) 316 RETURN 317C 318C--- IFUNC = 16, Flush buffer. ----------------------------------------- 319C (Not implemented: ignored.) 320C 321 160 CONTINUE 322 RETURN 323C 324C--- IFUNC = 17, Read cursor. ------------------------------------------ 325C (Not implemented: should not be called.) 326C 327 170 CONTINUE 328 GOTO 900 329C 330C--- IFUNC = 18, Erase alpha screen. ----------------------------------- 331C (Not implemented: ignored.) 332C 333 180 CONTINUE 334 RETURN 335C 336C--- IFUNC = 19, Set line style. --------------------------------------- 337C (Not implemented: should not be called.) 338C 339 190 CONTINUE 340 GOTO 900 341C 342C--- IFUNC = 20, Polygon fill. ----------------------------------------- 343C (Not implemented: should not be called.) 344C 345 200 CONTINUE 346 GOTO 900 347C 348C--- IFUNC = 21, Set color representation. ----------------------------- 349C 350 210 CONTINUE 351 I = INT (RBUF(1) + 1.5) 352 CTAB(1, I) = INT (RBUF(2) * 100.0 + 0.5) 353 CTAB(2, I) = INT (RBUF(3) * 100.0 + 0.5) 354 CTAB(3, I) = INT (RBUF(4) * 100.0 + 0.5) 355 RETURN 356C 357C--- IFUNC = 22, Set line width. --------------------------------------- 358C (Not implemented: should not be called.) 359C 360 220 CONTINUE 361 GOTO 900 362C 363C--- IFUNC = 23, Escape ------------------------------------------------ 364C (Not implemented: ignored.) 365C 366 230 CONTINUE 367 RETURN 368C 369C--- IFUNC = 24, Rectangle fill. --------------------------------------- 370C (Not implemented: should not be called.) 371C 372 240 CONTINUE 373 GOTO 900 374C 375C--- IFUNC = 25, ------------------------------------------------------- 376C (Not implemented: should not be called.) 377C 378 250 CONTINUE 379 GOTO 900 380C 381C--- IFUNC = 26, Line of pixels. --------------------------------------- 382C (Not implemented: should not be called.) 383C 384 260 CONTINUE 385 GOTO 900 386C----------------------------------------------------------------------- 387 END 388 389C*GRCC00 -- PGPLOT LJ250 driver, draw a colored line 390C+ 391 SUBROUTINE GRCC00 (LINE, RBUF, ICOL, BX, BY, BITMAP) 392 IMPLICIT NONE 393 INTEGER*4 BX, BY, ICOL, LINE 394 BYTE BITMAP(BX, BY) 395 REAL*4 RBUF(4) 396C 397C Draw a straight line segment from absolute pixel coordinates (RBUF(1), 398C RBUF(2)) to (RBUF(3), RBUF(4)). The line overwrites the previous 399C contents of the bitmap with the current color index. The line is 400C generated with a Simple Digital Differential Analyser (ref: Newman & 401C Sproull). 402C 403C Arguments: 404C 405C LINE I I =0 for dot, =1 for line. 406C RBUF(1),RBUF(2) I R Starting point of line. 407C RBUF(3),RBUF(4) I R Ending point of line. 408C ICOL I I Color index 409C BITMAP I/O B (address of) the frame buffer. 410C 411C----------------------------------------------------------------------- 412 INTEGER*4 K, KX, KY, LENGTH 413 REAL*4 D, XINC, XP, YINC, YP 414C----------------------------------------------------------------------- 415 IF (LINE .GT. 0) THEN 416 D = MAX (ABS (RBUF(3) - RBUF(1)), ABS (RBUF(4) - RBUF(2))) 417 LENGTH = D 418 IF (LENGTH .EQ. 0) THEN 419 XINC = 0.0 420 YINC = 0.0 421 ELSE 422 XINC = (RBUF(3) - RBUF(1)) / D 423 YINC = (RBUF(4) - RBUF(2)) / D 424 END IF 425 ELSE 426 LENGTH = 0 427 XINC = 0.0 428 YINC = 0.0 429 END IF 430 XP = RBUF(1) + 0.5 431 YP = RBUF(2) + 0.5 432 DO K = 0, LENGTH 433 KX = XP 434 KY = (BY - 1) - INT (YP) 435 BITMAP(KX + 1, KY + 1) = ICOL 436 XP = XP + XINC 437 YP = YP + YINC 438 END DO 439C----------------------------------------------------------------------- 440 RETURN 441 END 442 443C*GRCC01 -- PGPLOT LJ250 driver, copy bitmap to Sixel output file 444C+ 445 SUBROUTINE GRCC01 (LUN, BX, BY, BITMAP, NC, HIRES, CTAB) 446 IMPLICIT NONE 447 LOGICAL HIRES 448 INTEGER BX, BY, LUN, NC 449 BYTE BITMAP(BX, BY), CTAB(3, 256) 450C 451C Arguments: 452C 453C LUN (input) Fortran unit number for output 454C BX, BY (input) dimensions of BITMAP (BY MUST be a multiple of 6) 455C BITMAP (input) the bitmap array 456C NC (input) the maximum color index used in the bitmap 457C CTAB (input) the color table 458C----------------------------------------------------------------------- 459 BYTE ESC 460 INTEGER*4 BUFF, GRCC03, I, IER, J, K, L, GRGMEM, M 461 CHARACTER BLUE*3, COL*3, GREEN*3, RED*3 462 PARAMETER (ESC = 27) 463C----------------------------------------------------------------------- 464C Start Sixel graphics mode. 465 IF (HIRES) THEN 466 WRITE (LUN) ESC, 'P;1;;q"1;1;;-------' 467 ELSE 468 WRITE (LUN) ESC, 'P;1;8;q"1;1;;---' 469 END IF 470C Write out the color table. 471 DO I = 1, NC + 1 472 J = GRCC03 (I - 1) 473 K = CTAB(1, I) 474 K = GRCC03 (K) 475 L = CTAB(2, I) 476 L = GRCC03 (L) 477 M = CTAB(3, I) 478 M = GRCC03 (M) 479 WRITE (COL, '(I3)') I - 1 480 WRITE (RED, '(I3)') CTAB(1, I) 481 WRITE (GREEN, '(I3)') CTAB(2, I) 482 WRITE (BLUE, '(I3)') CTAB(3, I) 483 WRITE (LUN) '#', COL(4 - J : 3), ';2;', RED(4 - K : 3), ';', 484 1 GREEN(4 - L : 3), ';', BLUE(4 - M : 3) 485 END DO 486C Allocate a work array. 487 IER = GRGMEM (BX * (NC + 1), BUFF) 488C Check for an error. 489 IF (IER .NE. 1) THEN 490 CALL GRGMSG (IER) 491 CALL GRQUIT ('Failed to allocate temporary buffer.') 492 END IF 493C Output the Sixel data. 494 CALL GRCC02 (LUN, BX, BY, BITMAP, NC + 1, %VAL (BUFF)) 495C Turn off Sixel graphics mode. 496 WRITE (LUN) ESC, CHAR(92) 497C----------------------------------------------------------------------- 498 RETURN 499 END 500 501C*GRCC02 -- PGPLOT LJ250 driver, output the bitmap 502C+ 503 SUBROUTINE GRCC02 (LUN, BX, BY, BITMAP, NC, SIXEL) 504 IMPLICIT NONE 505 INTEGER BX, BY, LUN, NC 506 BYTE BITMAP(BX, BY), SIXEL(BX, NC) 507C 508C Version 1.0 18-Jun-1989 S. C. Allendorf 509C----------------------------------------------------------------------- 510 BYTE CH, QMASK(6) 511 LOGICAL OUTPUT 512 INTEGER*4 GRCC03, I, J, K, L, M, N, REPCNT 513 CHARACTER COL*3, OUTLINE*1445, REP*4 514 DATA QMASK /'01'X, '02'X, '04'X, '08'X, '10'X, '20'X/ 515C----------------------------------------------------------------------- 516C Output the Sixel data. 517 DO I = 1, BY / 6 518C Zero out the work array. 519 CALL GRCC04 (BX * NC, SIXEL) 520C Create a Sixel line. 521 DO J = 1, 6 522 DO K = 1, BX 523 L = BITMAP(K, (I - 1) * 6 + J) + 1 524 SIXEL(K, L) = SIXEL(K, L) .OR. QMASK(J) 525 END DO 526 END DO 527C Loop through each color plane. 528 DO J = 1, NC 529C Add the Sixel offset. 530 DO K = 1, BX 531 SIXEL(K, J) = SIXEL(K, J) + 63 532 END DO 533C Initialize some variables for 534C run-length encoding. 535 K = 1 536 L = 1 537 M = 1 538 OUTPUT = .FALSE. 539C Stop if we are at the end of the 540C line. 541 10 IF (K .LE. BX) THEN 542C Find the next character. 543 CH = SIXEL(K, J) 544C Count the repeats. 545 20 IF (M .LE. BX .AND. CH .EQ. SIXEL(M, J)) THEN 546 M = M + 1 547 GOTO 20 548 END IF 549C Determine the length. 550 REPCNT = M - K 551C See if there is any printable 552C data in this buffer. 553 IF (REPCNT .NE. BX .OR. SIXEL(M - 1, J) .NE. 63) THEN 554C Mark the buffer as containing 555C printable data. 556 OUTPUT = .TRUE. 557C Fill the output buffer. 558 IF (REPCNT .GE. 3) THEN 559 WRITE (REP, '(I4)') REPCNT 560 N = GRCC03 (REPCNT) 561 OUTLINE(L : L) = '!' 562 OUTLINE(L + 1 : L + N) = REP (5 - N : 4) 563 OUTLINE(L + N + 1 : L + N + 1) = 564 1 CHAR (SIXEL(M - 1, J)) 565 L = L + N + 2 566 ELSE 567 DO N = 0, REPCNT - 1 568 OUTLINE(L + N : L + N) = CHAR (SIXEL(M - 1, J)) 569 END DO 570 L = L + REPCNT 571 END IF 572 END IF 573C Reinitialize the starting point 574C for the next string and jump to 575C start of run length encoding. 576 K = M 577 GOTO 10 578 END IF 579C Write out the buffer if there is 580C any data in it. 581 IF (OUTPUT) THEN 582 WRITE (COL, '(I3)') J - 1 583 N = GRCC03 (J - 1) 584 WRITE (LUN) '#', COL(4 - N : 3), OUTLINE(1 : L - 1), '$' 585 END IF 586 END DO 587C Output a graphics linefeed. 588 WRITE (LUN) '-' 589 END DO 590C------------------------------------------------------------------------ 591 RETURN 592 END 593 594C*GRCC03 -- PGPLOT LJ250 driver, calculate length of an integer 595C+ 596 INTEGER FUNCTION GRCC03 (I) 597 INTEGER I 598C 599C This function calculates the number of digits in a supplied integer. 600C 601C Arguments: 602C 603C I I I Integer value of number 604C GRCC03 O I Length of printed representation of I 605C 606C Version 1.0 10-Feb-1988 S. C. Allendorf 607C----------------------------------------------------------------------- 608 IF (I .GE. 10) THEN 609 IF (I .GE. 100) THEN 610 IF (I .GE. 1000) THEN 611 GRCC03 = 4 612 ELSE 613 GRCC03 = 3 614 END IF 615 ELSE 616 GRCC03 = 2 617 END IF 618 ELSE 619 GRCC03 = 1 620 END IF 621C----------------------------------------------------------------------- 622 RETURN 623 END 624 625C*GRCC04 -- zero fill buffer 626C+ 627 SUBROUTINE GRCC04 (BUFSIZ,BUFFER) 628C 629C GRPCKG (internal routine): fill a buffer with a given character. 630C 631C Arguments: 632C 633C BUFFER (byte array, input): (address of) the buffer. 634C BUFSIZ (integer, input): number of bytes in BUFFER. 635C----------------------------------------------------------------------- 636 INTEGER BUFSIZ, I 637 BYTE BUFFER(BUFSIZ), FILL 638 DATA FILL /0/ 639C 640 DO 10 I=1,BUFSIZ 641 BUFFER(I) = FILL 642 10 CONTINUE 643 END 644