1C*LJDRIV -- PGPLOT Hewlett Packard LaserJet driver 2C+ 3 SUBROUTINE LJDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) 4 INTEGER IFUNC, NBUF, LCHR 5 REAL RBUF(*) 6 CHARACTER*(*) CHR 7C 8C PGPLOT driver for Hewlett packard Laserjet device. 9C 10C Version 1.0 - 1989 Apr 09 - S. C. Allendorf 11C Combined all drivers into one driver that 12C uses a logical name to choose the format. 13C TJP 1997-Jul-24: replaced ENCODE with WRITE, but still VMS-specific. 14C======================================================================= 15C 16C Supported device: Hewlett Packard LaserJet, LaserJet+, or LaserJet II. 17C 18C Device type code: /LJnn where nn is a number 1 - NDEV inclusive. 19C 20C Default device name: PGPLOT.LJPLT. 21C 22C Default view surface dimensions: Depends on which version of the driver 23C is chosen via the logical name PGPLOT_LJ_MODE. 24C 25C Driver Equivalence Size (H x V) 26C ------ ----------- --------------------- 27C LJ01 LHOR 10.50 by 8.00 inches 28C LJ02 PHOR 8.00 by 10.50 inches 29C LJ03 PHOT 8.00 by 10.50 inches 30C LJ04 LHBR 6.54 by 4.91 inches 31C LJ05 PHBS 5.65 by 5.65 inches 32C LJ06 LMBR 10.50 by 8.00 inches 33C LJ07 PMBR 8.00 by 10.50 inches 34C LJ08 PMBS 4.48 by 4.48 inches 35C LJ09 PLBS 6.00 by 6.00 inches 36C 37C Resolution: Depends on which version of the driver is chosen via the 38C logical name PGPLOT_LJ_MODE. 39C 40C Driver Equivalence Resolution 41C ------ ----------- ---------- 42C LJ01 LHOR 300 DPI 43C LJ02 PHOR 300 DPI 44C LJ03 PHOT 300 DPI 45C LJ04 LHBR 300 DPI 46C LJ05 PHBS 300 DPI 47C LJ06 LMBR 150 DPI 48C LJ07 PMBR 150 DPI 49C LJ08 PMBS 150 DPI 50C LJ09 PLBS 100 DPI 51C 52C Color capability: Color indices 0 (erase, white) and 1 (black) are 53C supported. It is not possible to change color representation. 54C 55C Input capability: None. 56C 57C File format: See the LaserJet Printer Technical Reference Manual for 58C details of the file format. 59C 60C Obtaining hardcopy: Use the command PRINT/PASSALL. 61C----------------------------------------------------------------------- 62C 63C To choose one of the specific LaserJet drivers, you must execute a DCL 64C command of the following form before executing your program: 65C 66C $ DEFINE PGPLOT_LJ_MODE LJnn 67C 68C where nn is a number 1 - NDEV inclusive. You may also use one of the 69C equivalent names listed above. These equivalent names are an attempt 70C to make the driver names make sense. They are decoded as follows: 71C 72C 1st character: P for protrait orientation or 73C L for landscape orientation. 74C 2nd character: H for high resolution (300 dpi) or 75C M for medium resolution (150 dpi) or 76C L for low resolution (100 dpi). 77C 3rd character: B for a straight bitmap dump (subroutine GRLJ01) or 78C O for an optimized bitmap dump (subroutine GRLJ02). 79C 4th character: R for a rectangular view surface or 80C S for a square view surface. 81C 82C A few notes are in order. First, not all of the possible combinations 83C above are supported (currently). The driver that goes by the name of 84C PHOT is a driver that puts out bitmaps suitable for inclusion in TeX 85C output if you are using the Arbortext DVIHP program. The only drivers 86C that will work with unexpanded LaserJet are LJ08 and LJ09. The other 87C seven drivers require a LaserJet Plus or LaserJet II. Finally, do NOT 88C attempt to send grayscale plots to the drivers that use the optimized 89C bitmap dumps. Terrible things will happen. 90C 91C If you add a driver to this file, please try to use the naming 92C convention outlined above and send me a copy of the revisions. I may 93C be reached at sca@iowa.physics.uiowa.edu on the Internet or IOWA::SCA 94C on SPAN. 95C----------------------------------------------------------------------- 96C This is the number of currently 97C installed devices. 98 INTEGER*4 NDEV 99 PARAMETER (NDEV = 9) 100C 101 BYTE ESC, FF 102 LOGICAL BITMAP(NDEV), INIT, PORTRAIT(NDEV), TEX 103 INTEGER BUFFER, BX, BY, DEVICE, HC(NDEV), I, IC, IER 104 INTEGER GRFMEM, GRGMEM, LUN, NPICT 105 INTEGER VC(NDEV) 106 REAL MAXX(NDEV), MAXY(NDEV), RESOL(NDEV), XBUF(4) 107 REAL XMAX, YMAX 108 CHARACTER ALTTYP(NDEV)*3, DEFNAM*12, MODE*20, MSG*10 109 CHARACTER TYPE(NDEV)*4 110 PARAMETER (ESC = 27) 111 PARAMETER (FF = 12) 112 PARAMETER (DEFNAM = 'pgplot.ljplt') 113 SAVE 114 DATA INIT /.TRUE./ 115C These are the NDEV sets of 116C device characteristics. 117 DATA BITMAP /.FALSE., .FALSE., .FALSE., .TRUE., .TRUE., 118 1 .TRUE., .TRUE., .TRUE., .TRUE./ 119 DATA PORTRAIT /.FALSE., .TRUE., .TRUE., .FALSE., .TRUE., 120 1 .FALSE., .TRUE., .TRUE., .TRUE./ 121 DATA HC / 0, 0, 0, 1139, 878, 122 1 0, 0, 1300, 754/ 123 DATA VC / 0, 0, 0, 1411, 1743, 124 1 0, 0, 2156, 1605/ 125 DATA MAXX / 3149.0, 2399.0, 2399.0, 1962.0, 1695.0, 126 1 1574.0, 1199.0, 671.0, 599.0/ 127 DATA MAXY / 2399.0, 3149.0, 3149.0, 1471.0, 1695.0, 128 1 1199.0, 1574.0, 671.0, 599.0/ 129 DATA RESOL / 300.0, 300.0, 300.0, 300.0, 300.0, 130 1 150.0, 150.0, 150.0, 100.0/ 131C These are around only for 132C (pre)historical reasons. 133 DATA ALTTYP / 'HPN', 'HPV', 'TEX', 'HPR', 'HPE', 134 1 'HPF', 'HPT', 'HPH', 'HPM'/ 135 DATA TYPE / 'LHOR', 'PHOR', 'PHOT', 'LHBR', 'PHBS', 136 1 'LMBR', 'PMBR', 'PMBS', 'PLBS'/ 137C----------------------------------------------------------------------- 138C First time, translate logical 139C name PGPLOT_LJ_MODE and set 140C device accordingly. 141 IF (INIT) THEN 142 CALL GRGENV ('LJ_MODE', MODE, I) 143 DO 1 I = 1, NDEV 144 WRITE (MSG, '(A2, I2.2)') 'LJ', I 145 IF (MODE(1:4) .EQ. TYPE(I) .OR. 146 1 MODE(1:3) .EQ. ALTTYP(I) .OR. 147 2 MODE(1:4) .EQ. MSG(1:4)) THEN 148 DEVICE = I 149 GOTO 2 150 END IF 151 1 CONTINUE 152C If no match, choose LHBR 153 DEVICE = 4 154 2 INIT = .FALSE. 155C See if user has chosen the 156C TeX plotfile format. 157 TEX = .FALSE. 158 IF (DEVICE .EQ. 3) TEX = .TRUE. 159 END IF 160C Branch on opcode. 161 GOTO ( 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 162 1 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 163 2 210, 220, 230, 240, 250, 260), IFUNC 164C Signal an error. 165 900 WRITE (MSG, '(I10)') IFUNC 166 CALL GRWARN ('Unimplemented function in LaserJet device driver:' 167 1 // MSG) 168 NBUF = -1 169 RETURN 170C 171C--- IFUNC = 1, Return device name ------------------------------------- 172C 173 10 CONTINUE 174 WRITE (MSG, '(I2.2)') DEVICE 175 CHR = 'LJ' // MSG(1 : 2) // ' (' // TYPE(DEVICE) // ')' 176 NBUF = 0 177 LCHR = 11 178 RETURN 179C 180C--- IFUNC = 2, Return physical min and max for plot device, and range 181C of color indices --------------------------------------- 182C 183 20 CONTINUE 184 RBUF(1) = 0.0 185 RBUF(2) = MAXX(DEVICE) 186 RBUF(3) = 0.0 187 RBUF(4) = MAXY(DEVICE) 188 RBUF(5) = 0.0 189 RBUF(6) = 1.0 190 NBUF = 6 191 LCHR = 0 192 RETURN 193C 194C--- IFUNC = 3, Return device resolution ------------------------------- 195C 196 30 CONTINUE 197 RBUF(1) = RESOL(DEVICE) 198 RBUF(2) = RESOL(DEVICE) 199 RBUF(3) = 1.0 200 NBUF = 3 201 LCHR = 0 202 RETURN 203C 204C--- IFUNC = 4, Return misc device info -------------------------------- 205C (This device is Hardcopy, No cursor, No dashed lines, No area fill, 206C no thick lines) 207C 208 40 CONTINUE 209 CHR = 'HNNNNNNNNN' 210 NBUF = 0 211 LCHR = 10 212 RETURN 213C 214C--- IFUNC = 5, Return default file name ------------------------------- 215C 216 50 CONTINUE 217 CHR = DEFNAM 218 NBUF = 0 219 LCHR = LEN(DEFNAM) 220 RETURN 221C 222C--- IFUNC = 6, Return default physical size of plot ------------------- 223C 224 60 CONTINUE 225 RBUF(1) = 0.0 226 RBUF(2) = MAXX(DEVICE) 227 RBUF(3) = 0.0 228 RBUF(4) = MAXY(DEVICE) 229 NBUF = 4 230 LCHR = 0 231 RETURN 232C 233C--- IFUNC = 7, Return misc defaults ----------------------------------- 234C 235 70 CONTINUE 236 IF (RESOL(DEVICE) .EQ. 300.0) THEN 237 RBUF(1) = 3.0 238 ELSE IF (RESOL(DEVICE) .EQ. 150.0) THEN 239 RBUF(1) = 2.0 240 ELSE 241 RBUF(1) = 1.0 242 END IF 243 NBUF = 1 244 LCHR = 0 245 RETURN 246C 247C--- IFUNC = 8, Select plot -------------------------------------------- 248C 249 80 CONTINUE 250 RETURN 251C 252C--- IFUNC = 9, Open workstation --------------------------------------- 253C 254 90 CONTINUE 255C Assume success. 256 RBUF(2) = 1.0 257C Obtain a logical unit number. 258 CALL GRGLUN (LUN) 259C Check for an error. 260 IF (LUN .EQ. -1) THEN 261 CALL GRWARN ('Cannot allocate a logical unit.') 262 RBUF(2) = 0 263 RETURN 264 ELSE 265 RBUF(1) = LUN 266 END IF 267C Open the output file. 268 OPEN (UNIT = LUN, FILE = CHR(:LCHR), CARRIAGECONTROL = 'NONE', 269 1 DEFAULTFILE = DEFNAM, STATUS = 'NEW', 270 2 RECL = 128, FORM = 'UNFORMATTED', RECORDTYPE = 'VARIABLE', 271 3 IOSTAT = IER) 272C Check for an error and cleanup if 273C one occurred. 274 IF (IER .NE. 0) THEN 275 CALL GRWARN ('Cannot open output file for LaserJet plot: ' // 276 1 CHR(:LCHR)) 277 RBUF(2) = 0 278 CALL GRFLUN (LUN) 279 RETURN 280 ELSE 281C Get the full file specification 282C and calculate the length of the 283C string 284 INQUIRE (UNIT = LUN, NAME = CHR) 285 LCHR = LEN (CHR) 286 91 IF (CHR (LCHR:LCHR) .EQ. ' ') THEN 287 LCHR = LCHR - 1 288 GOTO 91 289 END IF 290 END IF 291C Initialize the plot file. 292 293 IF (.NOT. TEX) THEN 294C Choose portrait orientation 295 WRITE (LUN) ESC, '&l0O' 296C Set horizontal and vertical 297C spacing 298 IF (BITMAP(DEVICE)) THEN 299 WRITE (LUN) ESC, '&l6C' 300 WRITE (LUN) ESC, '&k10H' 301 ELSE 302 WRITE (LUN) ESC, '&k.4H' 303 WRITE (LUN) ESC, '&l.16C' 304 END IF 305 WRITE (LUN) ESC, '&l2E' 306 END IF 307C Set the graphics resolution 308 WRITE (MSG, '(I3)') INT (RESOL(DEVICE)) 309 WRITE (LUN) ESC, '*t', MSG(1:3), 'R' 310C Initialize the page counter. 311 NPICT = 0 312 RETURN 313C 314C--- IFUNC = 10, Close workstation ------------------------------------- 315C 316 100 CONTINUE 317 IF (BITMAP(DEVICE)) THEN 318 WRITE (LUN) ESC, '&l8C' 319 ELSE IF (.NOT. TEX) THEN 320 WRITE (LUN) ESC, '&l6D' 321 WRITE (LUN) ESC, '&k10H' 322 WRITE (LUN) ESC, '&l2E' 323 END IF 324C Close the file. 325 CLOSE (LUN, STATUS = 'KEEP') 326C Deallocate the logical unit. 327 CALL GRFLUN (LUN) 328C 329 RETURN 330C 331C--- IFUNC = 11, Begin picture ----------------------------------------- 332C 333 110 CONTINUE 334C Set the bitmap size. 335 XMAX = RBUF(1) 336 YMAX = RBUF(2) 337C Calculate the dimensions of the 338C plot buffer. 339 IF (PORTRAIT(DEVICE)) THEN 340 BX = INT (XMAX) / 8 + 1 341 BY = INT (YMAX) + 1 342 ELSE 343 BX = INT (YMAX) / 8 + 1 344 BY = INT (XMAX) + 1 345 END IF 346C Allocate a plot buffer. 347 IER = GRGMEM (BX * BY, BUFFER) 348C Check for error and clean up 349C if one was found. 350 IF (IER .NE. 1) THEN 351 CALL GRGMSG (IER) 352 CALL GRQUIT ('Failed to allocate a plot buffer.') 353 END IF 354C Increment the page number. 355 NPICT = NPICT + 1 356C Eject the page from the printer. 357 IF (NPICT .GT. 1) WRITE (LUN) FF 358C Set the cursor position and 359C start graphics mode. 360 IF (BITMAP(DEVICE)) THEN 361 WRITE (MSG(1:4), '(I4.4)') HC(DEVICE) 362 WRITE (MSG(5:8), '(I4.4)') VC(DEVICE) 363 WRITE (LUN) ESC, '&a', MSG(1:4), 'h', MSG(5:8), 'V' 364 END IF 365C Zero out the plot buffer. 366 CALL GRLJ04 (BX * BY, %VAL(BUFFER)) 367 RETURN 368C 369C--- IFUNC = 12, Draw line --------------------------------------------- 370C 371 120 CONTINUE 372C Apply any needed tranformation. 373 IF (PORTRAIT(DEVICE)) THEN 374 DO 125 I = 1, 4 375 XBUF(I) = RBUF(I) 376 125 CONTINUE 377 ELSE 378 XBUF(1) = RBUF(2) 379 XBUF(2) = XMAX - RBUF(1) 380 XBUF(3) = RBUF(4) 381 XBUF(4) = XMAX - RBUF(3) 382 END IF 383C Draw the point into the bitmap. 384 CALL GRLJ00 (1, XBUF, IC, BX, BY, %VAL (BUFFER)) 385 RETURN 386C 387C--- IFUNC = 13, Draw dot ---------------------------------------------- 388C 389 130 CONTINUE 390C Apply any needed tranformation. 391 IF (PORTRAIT(DEVICE)) THEN 392 DO 135 I = 1, 2 393 XBUF(I) = RBUF(I) 394 135 CONTINUE 395 ELSE 396 XBUF(1) = RBUF(2) 397 XBUF(2) = XMAX - RBUF(1) 398 END IF 399C Draw the point into the bitmap. 400 CALL GRLJ00 (0, XBUF, IC, BX, BY, %VAL(BUFFER)) 401 RETURN 402C 403C--- IFUNC = 14, End picture ------------------------------------------- 404C 405 140 CONTINUE 406C Write out the bitmap. 407 IF (BITMAP(DEVICE)) THEN 408 CALL GRLJ01 (LUN, BX, BY, %VAL (BUFFER)) 409 ELSE 410 CALL GRLJ02 (LUN, BX, BY, %VAL (BUFFER), TEX) 411 END IF 412C Deallocate the plot buffer. 413 IER = GRFMEM (BX * BY, BUFFER) 414C Check for an error. 415 IF (IER .NE. 1) THEN 416 CALL GRGMSG (IER) 417 CALL GRWARN ('Failed to deallocate plot buffer.') 418 END IF 419 RETURN 420C 421C--- IFUNC = 15, Select color index ------------------------------------ 422C 423 150 CONTINUE 424C Save the requested color index. 425 IC = RBUF(1) 426C If out of range set to black. 427 IF (IC .LT. 0 .OR. IC .GT. 1) THEN 428 IC = 1 429 RBUF(1) = IC 430 END IF 431 RETURN 432C 433C--- IFUNC = 16, Flush buffer. ----------------------------------------- 434C (Not implemented: ignored.) 435C 436 160 CONTINUE 437 RETURN 438C 439C--- IFUNC = 17, Read cursor. ------------------------------------------ 440C (Not implemented: should not be called.) 441C 442 170 CONTINUE 443 GOTO 900 444C 445C--- IFUNC = 18, Erase alpha screen. ----------------------------------- 446C (Not implemented: ignored.) 447C 448 180 CONTINUE 449 RETURN 450C 451C--- IFUNC = 19, Set line style. --------------------------------------- 452C (Not implemented: should not be called.) 453C 454 190 CONTINUE 455 GOTO 900 456C 457C--- IFUNC = 20, Polygon fill. ----------------------------------------- 458C (Not implemented: should not be called.) 459C 460 200 CONTINUE 461 GOTO 900 462C 463C--- IFUNC = 21, Set color representation. ----------------------------- 464C (Not implemented: ignored.) 465C 466 210 CONTINUE 467 RETURN 468C 469C--- IFUNC = 22, Set line width. --------------------------------------- 470C (Not implemented: should not be called.) 471C 472 220 CONTINUE 473 GOTO 900 474C 475C--- IFUNC = 23, Escape ------------------------------------------------ 476C (Not implemented: ignored.) 477C 478 230 CONTINUE 479 RETURN 480C 481C--- IFUNC = 24, Rectangle fill. --------------------------------------- 482C (Not implemented: should not be called.) 483C 484 240 CONTINUE 485 GOTO 900 486C 487C--- IFUNC = 25, ------------------------------------------------------- 488C (Not implemented: should not be called.) 489C 490 250 CONTINUE 491 GOTO 900 492C 493C--- IFUNC = 26, Line of pixels. --------------------------------------- 494C (Not implemented: should not be called.) 495C 496 260 CONTINUE 497 GOTO 900 498C----------------------------------------------------------------------- 499 END 500 501C*GRLJ00 -- PGPLOT Hewlett Packard LaserJet driver, draw line 502C+ 503 SUBROUTINE GRLJ00 (LINE, RBUF, ICOL, BX, BY, BITMAP) 504 INTEGER BX, BY, ICOL, LINE 505 BYTE BITMAP(BX, BY) 506 REAL RBUF(4) 507C 508C Draw a straight line segment from absolute pixel coordinates (RBUF(1), 509C RBUF(2)) to (RBUF(3), RBUF(4)). The line either overwrites (sets to 510C black) or erases (sets to white) the previous contents of the bitmap, 511C depending on the current color index. Setting bits is accomplished 512C with a VMS BISB2 instruction, expressed in Fortran as .OR.; clearing 513C bits is accomplished with a VMS BICB2 instruction, expressed in 514C Fortran as .AND. .NOT.. The line is generated with a Simple Digital 515C Differential Analyser (ref: Newman & Sproull). 516C 517C Arguments: 518C 519C LINE I I =0 for dot, =1 for line. 520C RBUF(1),RBUF(2) I R Starting point of line. 521C RBUF(3),RBUF(4) I R Ending point of line. 522C ICOL I I =0 for erase, =1 for write. 523C BITMAP I/O B (address of) the frame buffer. 524C 525C----------------------------------------------------------------------- 526 BYTE QMASK(0 : 7) 527 INTEGER K, KX, KY, LENGTH 528 REAL D, XINC, XP, YINC, YP 529 DATA QMASK /'80'X, '40'X, '20'X, '10'X, 530 1 '08'X, '04'X, '02'X, '01'X/ 531C----------------------------------------------------------------------- 532 IF (LINE .GT. 0) THEN 533 D = MAX (ABS (RBUF(3) - RBUF(1)), ABS (RBUF(4) - RBUF(2))) 534 LENGTH = D 535 IF (LENGTH .EQ. 0) THEN 536 XINC = 0.0 537 YINC = 0.0 538 ELSE 539 XINC = (RBUF(3) - RBUF(1)) / D 540 YINC = (RBUF(4) - RBUF(2)) / D 541 END IF 542 ELSE 543 LENGTH = 0 544 XINC = 0.0 545 YINC = 0.0 546 END IF 547 XP = RBUF(1) + 0.5 548 YP = RBUF(2) + 0.5 549 IF (ICOL .NE. 0) THEN 550 DO K = 0, LENGTH 551 KX = XP 552 KY = (BY - 1) - INT (YP) 553 BITMAP(KX / 8 + 1, KY + 1) = BITMAP(KX / 8 + 1, KY + 1) .OR. 554 1 QMASK(MOD (KX, 8)) 555 XP = XP + XINC 556 YP = YP + YINC 557 END DO 558 ELSE 559 DO K = 0,LENGTH 560 KX = XP 561 KY = (BY - 1) - INT (YP) 562 BITMAP(KX / 8 + 1, KY + 1) = BITMAP(KX / 8 + 1, KY + 1) 563 1 .AND. (.NOT. QMASK(MOD (KX, 8))) 564 XP = XP + XINC 565 YP = YP + YINC 566 END DO 567 END IF 568C----------------------------------------------------------------------- 569 RETURN 570 END 571 572C*GRLJ01 -- PGPLOT LaserJet driver, copy bitmap to output file 573C+ 574 SUBROUTINE GRLJ01 (LUN, BX, BY, BITMAP) 575 INTEGER BX, BY, LUN 576 BYTE BITMAP(BX, BY) 577C 578C Arguments: 579C 580C LUN (input) Fortran unit number for output 581C BX, BY (input) dimensions of BITMAP 582C BITMAP (input) the bitmap array 583C----------------------------------------------------------------------- 584 BYTE ESC 585 INTEGER I, J, K 586 CHARACTER KSTR*3 587 PARAMETER (ESC = 27) 588C----------------------------------------------------------------------- 589C Start graphics mode 590 WRITE (LUN) ESC, '*r1A' 591C Loop through bitmap 592 DO J = 1, BY 593C Search for last non-NUL 594 DO K = BX, 2, -1 595 IF (BITMAP(K, J) .NE. '00'X) GO TO 10 596 END DO 597C Guarantee that we know what K 598C is after loop. 599C (Remember FORTRAN IV!?) 600 K = 1 601C Encode length of line 602 10 WRITE (KSTR, '(I3.3)') K 603C Write out the raster line 604 WRITE (LUN) ESC, '*b', KSTR, 'W', (BITMAP(I, J), I = 1, K) 605 END DO 606C Turn off graphics mode. 607 WRITE (LUN) ESC, '*rB' 608C----------------------------------------------------------------------- 609 RETURN 610 END 611 612C*GRLJ02 -- PGPLOT LaserJet+ driver, dump bitmap to device 613C+ 614 SUBROUTINE GRLJ02 (LUN, BX, BY, BITMAP, TEX) 615 LOGICAL TEX 616 INTEGER LUN, BX, BY 617 BYTE BITMAP(BX, BY) 618C 619C Output raster for this page. This routine has been optimised to 620C minimize the memory usage in the LaserJet. This sometimes leads to a 621C larger file than if a straight bitmap approach had been used. 622C 623C NOTE: This subroutine is a kludge to make a 512K LaserJet produce 624C full page plots at 300dpi. It will not always produce the plot 625C on one page. If you overrun the memory restrictions, two pages 626C will be printed, each containing parts of the plot. One must 627C then resort to cut and paste techniques to restore the plot. 628C Most simple line graphs do not come close to the memory limit, 629C but sometimes a messy contour plot will. DON'T EVEN THINK 630C ABOUT SENDING A GREYSCALE TO THIS SUBROUTINE! 631C 632C Arguments: 633C 634C LUN I I Logical unit number of output file 635C BX, BY I I Dimensions of frame buffer 636C BITMAP I/O B (address of) the frame buffer. 637C 638C Version 1.0 03-Sep-1986 S. C. Allendorf 639C Version 2.0 08-Dec-1986 S. C. Allendorf Use relative positioning 640C Version 2.1 28-Dec-1986 S. C. Allendorf Optimize positioning code 641C Version 3.0 02-Jan-1987 S. C. Allendorf Add code for rules 642C VERSION 3.1 10-FEB-1988 S. C. Allendorf Attempt to speed up code 643C----------------------------------------------------------------------- 644 BYTE ESC, N0 645 LOGICAL NOBIT 646 INTEGER CNUM, CONUM, CURCOL, CURROW, FB(35), FB2(25), I, IPOS 647 INTEGER IYOFF, J, K, L, M, N, NB(35), NBNUM, NBTOT, NBNUM2 648 INTEGER NB2(25), RNUM, RONUM, GRLJ03 649 CHARACTER ALLONE*300, COL*5, NBYTE*4, NULLS*(10), ROW*5, X*300 650 PARAMETER (N0 = 0) 651 PARAMETER (ESC = 27) 652C----------------------------------------------------------------------- 653C Define some useful constants 654 IF (TEX) THEN 655 IYOFF = 0 656 ELSE 657 IYOFF = 75 658 END IF 659 DO J = 1, 10 660 NULLS(J:J) = CHAR (0) 661 END DO 662 DO J = 1, 300 663 ALLONE(J:J) = CHAR (255) 664 END DO 665C Initialize some variables 666 CURCOL = 0 667 CURROW = 0 668C Position the cursor 669 IF (.NOT. TEX) THEN 670 WRITE (LUN) ESC, '*p0y0X' 671 END IF 672C Set up vertical rule height 673 WRITE (LUN) ESC, '*c1B' 674C Write out each line on page 675 DO K = 1, BY 676C Copy raster to buffer and find 677C the beginning and end of the 678C bitmap line 679 NOBIT = .TRUE. 680 NBTOT = 0 681 FB(1) = BX 682 DO J = 1, BX 683 X(J:J) = CHAR (BITMAP(J,K)) 684 IF (X(J:J) .NE. NULLS(1:1)) THEN 685 NOBIT = .FALSE. 686 NBTOT = J 687 FB(1) = MIN (FB(1), J) 688 END IF 689 END DO 690C Break line into pieces 691 IF (.NOT. NOBIT) THEN 692 L = 1 693 GO TO 20 694 10 NB(L) = FB(L) + IPOS - 2 695 L = L + 1 696C Search for first non-null 697 DO J = NB(L-1) + 11, NBTOT 698 IF (X(J:J) .NE. NULLS(1:1)) THEN 699 FB(L) = J 700 GO TO 20 701 END IF 702 END DO 703C Search for a string of nulls 704 20 IPOS = INDEX (X(FB(L):NBTOT), NULLS) 705 IF (IPOS .EQ. 0) THEN 706 NB(L) = NBTOT 707 GO TO 30 708 ELSE 709 GO TO 10 710 END IF 711C Loop through each substring 712 30 DO J = 1, L 713C Search for rules 714 M = 1 715 FB2(1) = FB(J) 716 GO TO 50 717 40 IF (IPOS .NE. 1) THEN 718 NB2(M) = 0 719 DO I = FB2(M), FB2(M) + IPOS - 2 720 IF (X(I:I) .NE. NULLS(1:1)) THEN 721 NB2(M) = MAX (FB2(M), I) 722 END IF 723 END DO 724 M = M + 1 725 FB2(M) = FB2(M-1) + IPOS - 1 726 IF (NB2(M-1) .EQ. 0) THEN 727 FB2(M-1) = FB2(M) 728 M = M - 1 729 END IF 730 END IF 731C Search for first non-<XFF> 732 DO N = FB2(M) + 25, NB(J) 733 IF (X(N:N) .NE. ALLONE(1:1)) THEN 734 NB2(M) = N - 1 735 M = M + 1 736 FB2(M) = N 737 GO TO 50 738 END IF 739 END DO 740 NB2(M) = NB(J) 741 GO TO 60 742C Search for a string of <XFF>s 743 50 IPOS = INDEX (X(FB2(M):NB(J)), ALLONE(1:25)) 744 IF (IPOS .EQ. 0) THEN 745 NB2(M) = NB(J) 746 GO TO 60 747 ELSE 748 GO TO 40 749 END IF 750C Print each of the substrings 751 60 DO I = 1, M 752C Get the number of bytes 753 NBNUM = NB2(I) - FB2(I) + 1 754C ENCODE (4, 1000, NBYTE) NBNUM 755 WRITE (NBYTE, 1000) NBNUM 756 NBNUM2 = GRLJ03 (NBNUM) 757C Calculate the row and column 758 RONUM = K + IYOFF 759 CONUM = (FB2(I) - 1) * 8 760C Determine the positioning 761C sequence and write it out 762 IF (RONUM .NE. CURROW .AND. CONUM .NE. CURCOL) THEN 763 RNUM = RONUM - CURROW 764 CNUM = CONUM - CURCOL 765C ENCODE (5, 1010, ROW) RNUM 766C ENCODE (5, 1010, COL) CNUM 767 WRITE (ROW, 1010) RNUM 768 WRITE (COL, 1010) CNUM 769 RNUM = GRLJ03 (ABS (RNUM)) + 1 770 CNUM = GRLJ03 (ABS (CNUM)) + 1 771 WRITE (LUN) ESC, '*p', ROW(6-RNUM:5), 'y', 772 + COL(6-CNUM:5), 'X' 773 ELSE IF (RONUM .NE. CURROW) THEN 774 RNUM = RONUM - CURROW 775C ENCODE (5, 1010, ROW) RNUM 776 WRITE (ROW, 1010) RNUM 777 RNUM = GRLJ03 (ABS (RNUM)) + 1 778 WRITE (LUN) ESC, '*p', ROW(6-RNUM:5), 'Y' 779 ELSE IF (CONUM .NE. CURCOL) THEN 780 CNUM = CONUM - CURCOL 781C ENCODE (5, 1010, COL) CNUM 782 WRITE (COL, 1010) CNUM 783 CNUM = GRLJ03 (ABS (CNUM)) + 1 784 WRITE (LUN) ESC, '*p', COL(6-CNUM:5), 'X' 785 END IF 786C Check for all bits set in 787C substring 788 IF ((INDEX (X(FB2(I):NB2(I)), ALLONE(1:NBNUM)) .EQ. 1) 789 + .AND. NBNUM .GE. 5) THEN 790 NBNUM = NBNUM * 8 791C ENCODE (4, 1000, NBYTE) NBNUM 792 WRITE (NBYTE, 1000) NBNUM 793 NBNUM2 = GRLJ03 (NBNUM) 794 WRITE (LUN) ESC, '*c', NBYTE(5-NBNUM2:4), 'A' 795 WRITE (LUN) ESC, '*c0P' 796 CURROW = RONUM 797 CURCOL = CONUM 798 ELSE 799C Write out raster line 800 WRITE (LUN) ESC, '*r1A' 801 WRITE (LUN) ESC, '*b', NBYTE(5-NBNUM2:4), 'W', 802 + X(FB2(I):NB2(I)) 803 WRITE (LUN) ESC, '*rB' 804 CURROW = RONUM + 1 805 CURCOL = CONUM 806 END IF 807 END DO 808 END DO 809 END IF 810 END DO 811C----------------------------------------------------------------------- 812 1000 FORMAT (I4.4) 813 1010 FORMAT (SP,I5) 814 RETURN 815 END 816 817C*GRLJ03 -- PGPLOT LaserJet+ driver, calculate length of an integer 818C+ 819 INTEGER FUNCTION GRLJ03 (I) 820 INTEGER I 821C 822C This function calculates the number of digits in a supplied integer. 823C 824C Arguments: 825C 826C I I I Integer value of number 827C GRLJ03 O I Length of printed representation of I 828C 829C Version 1.0 10-Feb-1988 S. C. Allendorf 830C----------------------------------------------------------------------- 831 IF (I .GE. 10) THEN 832 IF (I .GE. 100) THEN 833 IF (I .GE. 1000) THEN 834 GRLJ03 = 4 835 ELSE 836 GRLJ03 = 3 837 END IF 838 ELSE 839 GRLJ03 = 2 840 END IF 841 ELSE 842 GRLJ03 = 1 843 END IF 844C----------------------------------------------------------------------- 845 RETURN 846 END 847 848C*GRLJ04 -- zero fill buffer 849C+ 850 SUBROUTINE GRLJ04 (BUFSIZ,BUFFER) 851C 852C Arguments: 853C 854C BUFFER (byte array, input): (address of) the buffer. 855C BUFSIZ (integer, input): number of bytes in BUFFER. 856C----------------------------------------------------------------------- 857 INTEGER BUFSIZ, I 858 BYTE BUFFER(BUFSIZ), FILL 859 DATA FILL /0/ 860C 861 DO 10 I=1,BUFSIZ 862 BUFFER(I) = FILL 863 10 CONTINUE 864 END 865