1*HJDRIV -- PGPLOT Hewlett Packard [Desk/Laser] Jet driver 2C+ 3 SUBROUTINE HJDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) 4 INTEGER IFUNC, NBUF, LCHR 5 REAL RBUF(*) 6 CHARACTER*(*) CHR 7C 8C PGPLOT driver for Hewlett Packard Desk/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 Version 1.1 - 1989 Sept - B. H. Toby 14C (1) adapt for PC version of PGPLOT 15C (2) use alternate logical name definitions 16C (3) support for DeskJet/ " Plus/ " 500 17C (4) reduce page size to 10.25 to fix PGIDENT 18C 19C Version 1.2 - 1991 Aug - B. H. Toby 20C Clean up and add code for GRIFB1 since the 21C subroutine is not in GRPCKG as of PGPLOT V4.9d 22C 23C IBM PC / HP DeskJet printer usage 24C Default file name is LPT1 (parallel port#1) 25C Setup the port using MODE LPTn:,,P (parallel) 26C or MODE COMn:96,N,8,1,P (serial) 27C Use COMn/HJ or LPTn/HJ to send output directly to a device 28C or FILE.EXT/HJ or d:\path\file.ext/HJ to send the output 29C to a file 30C Files can be written to disk and then copied to the printer. 31C However, there is a problem in treating plot files, since they 32C may contain ^Z (end-of-file) and other control characters. Use 33C COPY file.ext /B LPT1: 34C to print the file. 35C Note that logical name PGPLOT_xx under VMS corresponds to MS-DOS 36C environment variable PG_xxx 37C Ported back to VAX/VMS, lines of code changed are indicated by a "C!" flag. 38C======================================================================= 39C 40C Supported device: Hewlett Packard LaserJet, LaserJet+, or LaserJet II. 41C DeskJet, DeskJet Plus, DeskJet 500 42C 43C Device type code: /HJ 44C 45C Default device name: PGPLOT.HJPLT. 46C 47C Default view surface dimensions: Depends on which driver settings are 48C chosen, via logical names PGPLOT_HJ_MODE, PGPLOT_HJ_MAR, PGPLOT_HJ_SIZE 49C and PGPLOT_HJ_PAGE. 50C 51C Resolution: Depends on which driver settings are chosen, via 52C logical names PGPLOT_HJ_MODE or PGPLOT_HJ_RES. 53C 54C Color capability: Color indices 0 (erase, white) and 1 (black) are 55C supported. It is not possible to change color representation. 56C 57C Input capability: None. 58C 59C File format: See the LaserJet & DeskJet Printer Technical Reference Manuals 60C for details of the file format. 61C 62C Obtaining hardcopy: Use the command PRINT/PASSALL. 63C 64C Logical Name Usage: 65C ------- ---- ------ 66C 67C PGPLOT_HJ_MODE: use $ DEFINE PGPLOT_HJ_MODE HJnn 68C 69C where nn is a number 1 - NDEV inclusive. You may also use one of the 70C equivalent names listed below. 71C Thus $ DEFINE PGPLOT_HJ_MODE HJ01 72C and $ DEFINE PGPLOT_HJ_MODE LHOR are equivalent (etc.) 73C The equivalent names are an attempt to make the driver names make 74C sense. They are decoded as follows: 75C 76C 1st character: P for protrait orientation or 77C L for landscape orientation. 78C 2nd character: H for high resolution (300 dpi) or 79C M for medium resolution (150 dpi) or 80C L for low resolution (100 dpi). 81C 3rd character: B for a straight bitmap dump (subroutine GRHJ01) or 82C O for an optimized bitmap dump (subroutine GRHJ02). 83C 4th character: R for a rectangular view surface or 84C S for a square view surface. 85C 86C A few notes are in order. First, not all of the possible combinations 87C above are supported (currently). The driver that goes by the name of 88C PHOT is a driver that puts out bitmaps suitable for inclusion in TeX 89C output if you are using the Arbortext DVIHP program. The only drivers 90C that will work with unexpanded LaserJet are HJ08 and HJ09. The other 91C seven drivers require a LaserJet Plus or LaserJet II. Finally, do NOT 92C attempt to send grayscale plots to the drivers that use the optimized 93C bitmap dumps. Terrible things will happen. 94C 95C Driver Equiv Size (H x V) Resolution 96C ------ ----- --------------------- ---------- 97C HJ01 LHOR 10.25 by 8.00 inches 300 DPI 98C HJ02 PHOR 8.00 by 10.25 inches 300 DPI 99C HJ03 PHOT 8.00 by 10.25 inches 300 DPI 100C HJ04 LHBR 6.54 by 4.91 inches 300 DPI 101C HJ05 PHBS 5.65 by 5.65 inches 300 DPI 102C HJ06 LMBR 10.25 by 8.00 inches 150 DPI 103C HJ07 PMBR 8.00 by 10.25 inches 150 DPI 104C HJ08 PMBS 4.48 by 4.48 inches 150 DPI 105C HJ09 PLBS 6.00 by 6.00 inches 100 DPI 106C 107C The following logical names will override the PGPLOT_HJ_MODE settings, 108C if used. 109C 110C PGPLOT_HJ_RES: use $ DEFINE PGPLOT_HJ_RES x where x is H, M, L or V 111C H or HIGH for 300 bpi 112C M or MEDIUM for 150 bpi 113C L or LOW for 100 bpi 114C V or VERYLOW for 75 bpi 115C 116C PGPLOT_HJ_MAR: use $ DEFINE PGPLOT_HJ_MAR "xx.xx,yy.yy" 117C where "xx.xx" and "yy.yy" are the vertical and horizontal 118C margin dimensions in inches. The number of characters, including 119C spaces preceeding and following the comma, should not exceed five. 120C $ DEFINE PGPLOT_HJ_MAR "1.0,1.0" is valid 121C $ DEFINE PGPLOT_HJ_MAR " 1.0 ,1.0" is valid 122C but $ DEFINE PGPLOT_HJ_MAR " 1.00 ,1.0" is not valid 123C 124C PGPLOT_HJ_SIZE: use $ DEFINE PGPLOT_HJ_SIZE "xx.xx,yy.yy" 125C where "xx.xx" and "yy.yy" are the vertical and horizontal 126C plot dimensions in inches. The number of characters, including 127C spaces preceeding and following the comma, should not exceed five. 128C $ DEFINE PGPLOT_HJ_SIZE "10.,8." is valid 129C $ DEFINE PGPLOT_HJ_SIZE "10.0 , 8.0 " is valid 130C but $ DEFINE PGPLOT_HJ_SIZE " 10.0 ,8.0" is not valid 131C 132C PGPLOT_HJ_TEX: use $ DEFINE PGPLOT_HJ_TEX T 133C if PGPLOT_HJ_TEX is defined with any value, TeX mode (see above) 134C will be used. 135C 136C PGPLOT_HJ_NOFF: use $ DEFINE PGPLOT_HJ_NOFF T 137C if PGPLOT_HJ_NOFF is defined with any value, the form feed 138C needed to eject the final page will be omitted. This is useful 139C for spooled printers -- it prevents wasted (blank) pages. 140C 141C PGPLOT_HJ_PAGE: use $ DEFINE PGPLOT_HJ_PAGE x where x is L or P 142C Use L (or LANDSCAPE) for Landscape mode 143C Use P (or PORTRAIT) for Portrait mode 144C 145C PGPLOT_HJ_OPT: use $ DEFINE PGPLOT_HJ_OPT x where x is O or C 146C Use O (or OPTIMIZE) so that bitmap will be "optimized" 147C Use C (or COMPRESS) so that bitmap will be "compressed" 148C 149C "Optimized" mode minimizes the memory usage for the LaserJet devices. 150C This sometimes leads to a larger file than if optimization is not 151C used. Optimized mode may not be used with the DeskJet devices. 152C 153C "Compressed" mode decreases the size of the bitmap file for later 154C model HP devices, particularly the DeskJet devices. 155C 156C----------------------------------------------------------------------- 157C 158C This driver was originally written by S. C. Allendorf and modified 159C by B. H. Toby. Any bugs are likely due to my (BHT) kludges. Send 160C improvements and fixes to this driver to sca@iowa.physics.uiowa.edu 161C (Internet) or IOWA::SCA (SPAN) and to TOBY@PETVAX.LRSM.UPENN.EDU. 162C 163C----------------------------------------------------------------------- 164C This is the number of currently 165C installed device types. 166 INTEGER*4 NDEV 167 PARAMETER (NDEV = 9) 168C 169 LOGICAL INIT /.TRUE./ 170 INTEGER*4 BX, BY, DEVICE, I, IC, IER 171 INTEGER*4 LUN, NPICT 172 REAL*4 XBUF(4) 173 REAL*4 XMAX, YMAX 174 CHARACTER ALTTYP(NDEV)*3, MODE*30, MSG*10 175 CHARACTER TYPE(NDEV)*4 176 INTEGER GRTRIM 177C! VAX/VMS 178 INTEGER*4 GRFMEM, GRGMEM 179 CHARACTER DEFNAM*12 180 PARAMETER (DEFNAM = 'PGPLOT.HJPLT') 181 BYTE ESC, FF 182 INTEGER*4 BUFFER 183C! PC: 184C! CHARACTER DEFNAM*4 185C! PARAMETER (DEFNAM = 'LPT1') 186C! INTEGER*1 ESC, FF 187C! INTEGER*1 BUFFER[ALLOCATABLE, HUGE] (:,:) 188C 189 PARAMETER (ESC = 27) 190 PARAMETER (FF = 12) 191C actual settings 192 LOGICAL TEX,NOFF 193 REAL*4 T1,T2 194 REAL*4 dev_VC, dev_HC 195 REAL*4 dev_resol,dev_maxX,dev_maxY 196 LOGICAL dev_bitmap_L, dev_port_L, dev_cmprs_L 197 CHARACTER dev_name*80 198 199C These are the NDEV sets of 200C device characteristics. 201 LOGICAL BITMAP(NDEV) 202 1 /.FALSE., .FALSE., .FALSE., .TRUE., .TRUE., 203 2 .TRUE., .TRUE., .TRUE., .TRUE./ 204 LOGICAL PORTRAIT(NDEV) 205 1 /.FALSE., .TRUE., .TRUE., .FALSE., .TRUE., 206 2 .FALSE., .TRUE., .TRUE., .TRUE./ 207 REAL*4 HC(NDEV) 208 1 / 0., 0., 0., 1.58, 1.22, 209 2 0., 0., 1.80, 1.05/ 210 REAL*4 VC(NDEV) 211 1 / 0., 0., 0., 1.96, 2.42, 212 2 0., 0., 3.00, 2.23/ 213 REAL*4 XPAGMX(NDEV) 214 1 / 10.25, 8.00, 8.00, 6.54, 5.65, 215 2 10.25, 8.00, 4.48, 6.00/ 216 REAL*4 YPAGMX(NDEV) 217 1 / 8.00, 10.25, 10.25, 4.91, 5.65, 218 2 8.00, 10.25, 4.48, 6.00/ 219 INTEGER*2 RESOL(NDEV) 220 1 / 300, 300, 300, 300, 300, 221 2 150, 150, 150, 100/ 222C Names for PGPLOT_HJ_MODE 223 DATA TYPE / 'LHOR', 'PHOR', 'PHOT', 'LHBR', 'PHBS', 224 1 'LMBR', 'PMBR', 'PMBS', 'PLBS'/ 225C These names are around only for (pre)historical reasons. 226 DATA ALTTYP / 'HPN', 'HPV', 'TEX', 'HPR', 'HPE', 227 1 'HPF', 'HPT', 'HPH', 'HPM'/ 228C----------------------------------------------------------------------- 229C----------------------------------------------------------------------- 230C First time, translate logical 231C name PGPLOT_HJ_MODE and set 232C device accordingly. 233 IF (INIT) THEN 234 CALL GRGENV ('HJ_MODE', MODE, I) 235 DO 1 I = 1, NDEV 236 WRITE (MSG, '(A2, I2.2)') 'HJ', I 237 IF (MODE(1:4) .EQ. TYPE(I) .OR. 238 1 MODE(1:3) .EQ. ALTTYP(I) .OR. 239 2 MODE(1:4) .EQ. MSG(1:4)) THEN 240 DEVICE = I 241 GOTO 2 242 END IF 243 1 CONTINUE 244C If no match, choose LMBR 245 DEVICE = 6 246 2 INIT = .FALSE. 247C See if user has chosen the 248C TeX plotfile format. 249 TEX = .FALSE. 250 IF (DEVICE .EQ. 3) TEX = .TRUE. 251 dev_cmprs_L = .FALSE. 252C----------------------------------------------------------------------- 253C set actual device settings from table entries 254C dev_VC and dev_HC are margin settings in inches: for non-optimized bitmaps 255 dev_VC = VC(DEVICE) 256 dev_HC = HC(DEVICE) 257C dev_resol is the resolution in dots per inch 258 dev_resol = RESOL(DEVICE) 259C dev_maxX and dev_maxY are the X and Y plot limits in inches 260 dev_maxX = Xpagmx(DEVICE) 261 dev_maxY = Ypagmx(DEVICE) 262C if dev_bitmap_L is false then the file can be optimized 263 dev_bitmap_L = BITMAP(DEVICE) 264C if dev_port_L is false then a landscape orientation is used 265 dev_port_L = PORTRAIT(DEVICE) 266C if TEX is true then much of the device control code is omitted so that 267C the file can be included by the TeX post-processor 268C----------------------------------------------------------------------- 269C Override the device settings according to logical variables: 270C PGPLOT_HJ_RES can be H or HIGH for 300 bpi 271C M or MEDIUM for 150 bpi 272C L or LOW for 100 bpi 273C V or VERYLOW for 75 bpi 274 CALL GRGENV ('HJ_RES', MODE, I) 275 IF (mode(1:1) .eq. 'H') then 276 dev_resol = 300 277 ELSEIF (mode(1:1) .eq. 'M') then 278 dev_resol = 150 279 ELSEIF (mode(1:1) .eq. 'L') then 280 dev_resol = 100 281 ELSEIF (mode(1:1) .eq. 'V') then 282 dev_resol = 75 283C! ELSE 284C! for PC, set resolution to 150 dpi or less unless it has been 285C! specifically set to 300 286C! dev_resol = min(150.,dev_resol) 287 ENDIF 288C PGPLOT_HJ_MAR contains the vertical and horizontal margins in inches 289 CALL GRGENV ('HJ_MAR', MODE, I) 290 IF (i .gt. 0 .and. mode(:I) .ne. ' ') THEN 291 read(mode(:I),'(2f6.0)',err=34) t1,t2 292 dev_VC = t1 293 dev_HC = t2 294 ENDIF 295C PGPLOT_HJ_SIZE if defined contains the X and Y page size in inches 29634 CALL GRGENV ('HJ_SIZE', MODE, I) 297 IF (i .gt. 0 .and. mode(:I) .ne. ' ') THEN 298 read(mode(:I),'(2f6.0)',err=35) t1,t2 299 dev_maxX = t1 300 dev_maxY = t2 301 ENDIF 302C PGPLOT_HJ_TEX can have any value, if defined will set TeX mode 30335 CALL GRGENV ('HJ_TEX', MODE, I) 304 IF (i .gt. 0 .and. mode .ne. ' ') then 305 TEX = .TRUE. 306 ENDIF 307C PGPLOT_HJ_NOFF can have any value, if defined will skip the final 308C form feed -- this prevents wasted (blank) pages from spooled jobs 309 NOFF = .false. 310 CALL GRGENV ('HJ_NOFF', MODE, I) 311 IF ((i .gt. 0 .and. mode .ne. ' ') .or. TEX) then 312 NOFF = .true. 313 ENDIF 314C If PGPLOT_HJ_PAGE is set to L (or LANDSCAPE) for Landscape mode 315C is set to P (or PORTRAIT) for Portrait mode 316 CALL GRGENV ('HJ_PAGE', MODE, I) 317 IF (mode(1:1) .eq. 'L' .or. mode(1:1) .eq. 'l') 318 1 dev_port_L = .false. 319 IF (mode(1:1) .eq. 'P' .or. mode(1:1) .eq. 'p') 320 1 dev_port_L = .true. 321C If PGPLOT_HJ_OPT is set to O (or OPTIMIZE) the bitmap will be optimized 322C is set to C (or COMPRESS) the bitmap will be compressed 323 CALL GRGENV ('HJ_OPT', MODE, I) 324 IF (mode(1:1) .eq. 'O' .or. mode(1:1) .eq. 'o') 325 1 dev_bitmap_L = .FALSE. 326 IF (mode(1:1) .eq. 'C' .or. mode(1:1) .eq. 'c') 327 1 dev_cmprs_L = .TRUE. 328C Define the device name to include the settings: name will be of form 329C /HJ -string 330C where the string will be "obrT x.x y.y" where 331C o P for Portrait orientation, L for landscape, blank otherwise 332C b O for optimized bitmaps, C for compressed bitmaps, B otherwise 333C r is the resolution in dots per inch: 300 - H; 150 - M; 100 - L; 75 - V 334C T for TeX mode, blank otherwise 335C x.x is the size of the page in the x direction 336C y.y is the size of the page in the y direction 337 mode = 'L B' 338 IF (dev_port_L) mode(1:1) = 'P' 339 IF (.not. dev_bitmap_L) mode(2:2) = 'O' 340 IF (dev_cmprs_L) mode(2:2) = 'C' 341 IF (dev_resol .eq. 300) then 342 mode(3:3) = 'H' 343 ELSEIF (dev_resol .eq. 150) then 344 mode(3:3) = 'M' 345 ELSEIF (dev_resol .eq. 100) then 346 mode(3:3) = 'L' 347 ELSEIF (dev_resol .eq. 75) then 348 mode(3:3) = 'V' 349 ELSE 350 mode(3:3) = '?' 351 ENDIF 352 IF (TEX) mode(4:4) = 'T' 353 IF (dev_maxX .gt. 10) then 354 WRITE (mode(5:),'(f3.0)') dev_maxX 355 ELSE 356 WRITE (mode(5:),'(f3.1)') dev_maxX 357 ENDIF 358 IF (dev_maxY .gt. 10) then 359 WRITE (mode(9:),'(f3.0)') dev_maxY 360 ELSE 361 WRITE (mode(9:),'(f3.1)') dev_maxY 362 ENDIF 363 DEV_NAME = 'HJ (Hewlett-Packard Deskjet/Laserjet) ' // mode 364 ENDIF 365C----------------------------------------------------------------------- 366C Branch on opcode. 367 GOTO ( 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 368 1 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 369 2 210, 220, 230, 240, 250, 260), IFUNC 370C Signal an error. 371 900 WRITE (MSG, '(I10)') IFUNC 372 CALL GRWARN ('Unimplemented function in HJ "Jet" device driver:' 373 1 // MSG) 374 NBUF = -1 375 RETURN 376C 377C--- IFUNC = 1, Return device name ------------------------------------- 378C 379 10 CONTINUE 380 CHR = dev_name 381 NBUF = 0 382 LCHR = GRTRIM(dev_name) 383 RETURN 384C 385C--- IFUNC = 2, Return physical min and max for plot device, and range 386C of color indices --------------------------------------- 387C 388 20 CONTINUE 389 RBUF(1) = 0.0 390C convert dev_maxX and dev_maxY from inches to pixels 391 RBUF(2) = dev_maxX * dev_resol - 1 392 RBUF(3) = 0.0 393 RBUF(4) = dev_maxY * dev_resol - 1 394 RBUF(5) = 0.0 395 RBUF(6) = 1.0 396 NBUF = 6 397 LCHR = 0 398 RETURN 399C 400C--- IFUNC = 3, Return device resolution ------------------------------- 401C 402 30 CONTINUE 403 RBUF(1) = dev_resol 404 RBUF(2) = dev_resol 405 RBUF(3) = 1.0 406 NBUF = 3 407 LCHR = 0 408 RETURN 409C 410C--- IFUNC = 4, Return misc device info -------------------------------- 411C (This device is Hardcopy, No cursor, No dashed lines, No area fill, 412C no thick lines) 413C 414 40 CONTINUE 415 CHR = 'HNNNNNNNNN' 416 NBUF = 0 417 LCHR = 10 418 RETURN 419C 420C--- IFUNC = 5, Return default file name ------------------------------- 421C 422 50 CONTINUE 423 CHR = DEFNAM 424 NBUF = 0 425 LCHR = LEN(DEFNAM) 426 RETURN 427C 428C--- IFUNC = 6, Return default physical size of plot ------------------- 429C 430 60 CONTINUE 431 RBUF(1) = 0.0 432C convert dev_maxX and dev_maxY from inches to pixels 433 RBUF(2) = dev_maxX * dev_resol - 1 434 RBUF(3) = 0.0 435 RBUF(4) = dev_maxY * dev_resol - 1 436 NBUF = 4 437 LCHR = 0 438 RETURN 439C 440C--- IFUNC = 7, Return misc defaults ----------------------------------- 441C 442 70 CONTINUE 443 IF (dev_resol .EQ. 300.0) THEN 444 RBUF(1) = 3.0 445 ELSE IF (dev_resol .EQ. 150.0) THEN 446 RBUF(1) = 2.0 447 ELSE 448 RBUF(1) = 1.0 449 END IF 450 NBUF = 1 451 LCHR = 0 452 RETURN 453C 454C--- IFUNC = 8, Select plot -------------------------------------------- 455C 456 80 CONTINUE 457 RETURN 458C 459C--- IFUNC = 9, Open workstation --------------------------------------- 460C 461 90 CONTINUE 462C Assume success. 463 RBUF(2) = 1.0 464C Obtain a logical unit number. 465 CALL GRGLUN (LUN) 466C Check for an error. 467 IF (LUN .EQ. -1) THEN 468 CALL GRWARN ('Cannot allocate a logical unit.') 469 RBUF(2) = 0 470 RETURN 471 ELSE 472 RBUF(1) = LUN 473 END IF 474C Open the output file. 475 OPEN (UNIT = LUN, FILE = CHR(:LCHR), CARRIAGECONTROL = 'NONE', 476 1 DEFAULTFILE = DEFNAM, STATUS = 'NEW', 477 2 RECL = 128, FORM = 'UNFORMATTED', RECORDTYPE = 'VARIABLE', 478 3 IOSTAT = IER) 479C! OPEN (UNIT = LUN, FILE = CHR(:LCHR), STATUS = 'UNKNOWN', 480C! 2 FORM = 'BINARY', 481C! 3 IOSTAT = IER) 482C Check for an error and cleanup if 483C one occurred. 484 IF (IER .NE. 0) THEN 485 CALL GRWARN ('Cannot open output file for HP "Jet: plot: ' // 486 1 CHR(:LCHR)) 487C! CALL GRWARN ('Cannot open output file for HP "Jet" plot: ') 488C! CALL GRWARN (CHR(:LCHR)) 489 RBUF(2) = 0 490 CALL GRFLUN (LUN) 491 RETURN 492 ELSE 493C Get the full file specification 494C and calculate the length of the 495C string 496 INQUIRE (UNIT = LUN, NAME = CHR) 497 LCHR = LEN (CHR) 498 91 IF (CHR (LCHR:LCHR) .EQ. ' ') THEN 499 LCHR = LCHR - 1 500 GOTO 91 501 END IF 502 END IF 503C Initialize the plot file. 504 505 IF (.NOT. TEX) THEN 506C Choose portrait orientation 507 WRITE (LUN) ESC, '&l0O' 508C Set horizontal and vertical 509C spacing 510 IF (dev_bitmap_L) THEN 511 WRITE (LUN) ESC, '&l6C' 512 WRITE (LUN) ESC, '&k10H' 513 ELSE 514 WRITE (LUN) ESC, '&k.4H' 515 WRITE (LUN) ESC, '&l.16C' 516 END IF 517 WRITE (LUN) ESC, '&l2E' 518 END IF 519C Set the graphics resolution 520 WRITE (MSG, '(I3.3)') INT (dev_resol) 521 WRITE (LUN) ESC, '*t', MSG(1:3), 'R' 522C Initialize the page counter. 523 NPICT = 0 524 RETURN 525C 526C--- IFUNC = 10, Close workstation ------------------------------------- 527C 528 100 CONTINUE 529 IF (dev_bitmap_L) THEN 530 WRITE (LUN) ESC, '&l8C' 531 ELSEIF (.NOT. TEX) THEN 532 WRITE (LUN) ESC, '&l6D' 533 WRITE (LUN) ESC, '&k10H' 534 WRITE (LUN) ESC, '&l2E' 535 END IF 536C eject the page 537 IF (.not. NOFF) WRITE (LUN) FF 538C Close the file. 539 CLOSE (LUN, STATUS = 'KEEP') 540C Deallocate the logical unit. 541 CALL GRFLUN (LUN) 542C 543 RETURN 544C 545C--- IFUNC = 11, Begin picture ----------------------------------------- 546C 547 110 CONTINUE 548C Set the bitmap size. 549 XMAX = RBUF(1) 550 YMAX = RBUF(2) 551C Calculate the dimensions of the 552C plot buffer. 553 IF (dev_port_L) THEN 554 BX = INT (XMAX) / 8 + 1 555 BY = INT (YMAX) + 1 556 ELSE 557 BX = INT (YMAX) / 8 + 1 558 BY = INT (XMAX) + 1 559 END IF 560C Allocate a plot buffer. 561C Check for error and clean up 562C if one was found. 563C! VAX 564 IER = GRGMEM (BX * BY, BUFFER) 565 IF (IER .NE. 1) THEN 566 CALL GRGMSG (IER) 567C! PC 568C! ALLOCATE (BUFFER(BX,BY), STAT = IER) 569C! IF (IER .NE. 0) THEN 570 CALL GRQUIT ('Failed to allocate a plot buffer.') 571 END IF 572C Increment the page number. 573 NPICT = NPICT + 1 574C Eject the page from the printer. 575 IF (NPICT .GT. 1) WRITE (LUN) FF 576C Set the cursor position and 577C start graphics mode. 578 IF (dev_bitmap_L) THEN 579 WRITE (MSG(1:4), '(I4.4)') nint(dev_HC*720.) 580 WRITE (MSG(5:8), '(I4.4)') nint(dev_VC*720.) 581 WRITE (LUN) ESC, '&a', MSG(1:4), 'h', MSG(5:8), 'V' 582 END IF 583C Zero out the plot buffer. 584 CALL GRHJ05 (BX * BY, %VAL(BUFFER)) 585 RETURN 586C 587C--- IFUNC = 12, Draw line --------------------------------------------- 588C 589 120 CONTINUE 590C Apply any needed tranformation. 591 IF (dev_port_L) THEN 592 DO 125 I = 1, 4 593 XBUF(I) = RBUF(I) 594 125 CONTINUE 595 ELSE 596 XBUF(1) = RBUF(2) 597 XBUF(2) = XMAX - RBUF(1) 598 XBUF(3) = RBUF(4) 599 XBUF(4) = XMAX - RBUF(3) 600 END IF 601C Draw the point into the bitmap. 602 CALL GRHJ00 (1, XBUF, IC, BX, BY, %VAL (BUFFER)) 603C! CALL GRHJ00 (1, XBUF, IC, BX, BY, BUFFER) 604 RETURN 605C 606C--- IFUNC = 13, Draw dot ---------------------------------------------- 607C 608 130 CONTINUE 609C Apply any needed tranformation. 610 IF (dev_port_L) THEN 611 DO 135 I = 1, 2 612 XBUF(I) = RBUF(I) 613 135 CONTINUE 614 ELSE 615 XBUF(1) = RBUF(2) 616 XBUF(2) = XMAX - RBUF(1) 617 END IF 618C Draw the point into the bitmap. 619 CALL GRHJ00 (0, XBUF, IC, BX, BY, %VAL(BUFFER)) 620C! CALL GRHJ00 (0, XBUF, IC, BX, BY, BUFFER) 621 RETURN 622C 623C--- IFUNC = 14, End picture ------------------------------------------- 624C 625 140 CONTINUE 626C Write out the bitmap. 627 IF (dev_bitmap_L .and. dev_cmprs_L) THEN 628 CALL GRHJ04 (LUN, BX, BY, %VAL(BUFFER)) 629C! CALL GRHJ04 (LUN, BX, BY, BUFFER) 630 ELSEIF (dev_bitmap_L) THEN 631 CALL GRHJ01 (LUN, BX, BY, %VAL (BUFFER)) 632C! CALL GRHJ01 (LUN, BX, BY, BUFFER) 633 ELSE 634 CALL GRHJ02 (LUN, BX, BY, %VAL (BUFFER), TEX) 635C! CALL GRHJ02 (LUN, BX, BY, BUFFER, TEX) 636 END IF 637C Deallocate the plot buffer. 638C Check for an error. 639C! VAX 640 IER = GRFMEM (BX * BY, BUFFER) 641 IF (IER .NE. 1) THEN 642 CALL GRGMSG (IER) 643C! PC 644C! DEALLOCATE (BUFFER, STAT=IER) 645C! IF (IER .NE. 0) THEN 646 CALL GRWARN ('Failed to deallocate plot buffer.') 647 END IF 648 RETURN 649C 650C--- IFUNC = 15, Select color index ------------------------------------ 651C 652 150 CONTINUE 653C Save the requested color index. 654 IC = RBUF(1) 655C If out of range set to black. 656 IF (IC .LT. 0 .OR. IC .GT. 1) THEN 657 IC = 1 658 RBUF(1) = IC 659 END IF 660 RETURN 661C 662C--- IFUNC = 16, Flush buffer. ----------------------------------------- 663C (Not implemented: ignored.) 664C 665 160 CONTINUE 666 RETURN 667C 668C--- IFUNC = 17, Read cursor. ------------------------------------------ 669C (Not implemented: should not be called.) 670C 671 170 CONTINUE 672 GOTO 900 673C 674C--- IFUNC = 18, Erase alpha screen. ----------------------------------- 675C (Not implemented: ignored.) 676C 677 180 CONTINUE 678 RETURN 679C 680C--- IFUNC = 19, Set line style. --------------------------------------- 681C (Not implemented: should not be called.) 682C 683 190 CONTINUE 684 GOTO 900 685C 686C--- IFUNC = 20, Polygon fill. ----------------------------------------- 687C (Not implemented: should not be called.) 688C 689 200 CONTINUE 690 GOTO 900 691C 692C--- IFUNC = 21, Set color representation. ----------------------------- 693C (Not implemented: ignored.) 694C 695 210 CONTINUE 696 RETURN 697C 698C--- IFUNC = 22, Set line width. --------------------------------------- 699C (Not implemented: should not be called.) 700C 701 220 CONTINUE 702 GOTO 900 703C 704C--- IFUNC = 23, Escape ------------------------------------------------ 705C (Not implemented: ignored.) 706C 707 230 CONTINUE 708 RETURN 709C 710C--- IFUNC = 24, Rectangle fill. --------------------------------------- 711C (Not implemented: should not be called.) 712C 713 240 CONTINUE 714 GOTO 900 715C 716C--- IFUNC = 25, ------------------------------------------------------- 717C (Not implemented: should not be called.) 718C 719 250 CONTINUE 720 GOTO 900 721C 722C--- IFUNC = 26, Line of pixels. --------------------------------------- 723C (Not implemented: should not be called.) 724C 725 260 CONTINUE 726 GOTO 900 727C----------------------------------------------------------------------- 728 END 729 730C*GRHJ00 -- PGPLOT Hewlett Packard LaserJet driver, draw line 731C+ 732 SUBROUTINE GRHJ00 (LINE, RBUF, ICOL, BX, BY, BITMAP) 733 INTEGER*4 BX, BY, ICOL, LINE 734 BYTE BITMAP(BX, BY) 735C! INTEGER*1 BITMAP(BX, BY) 736 REAL*4 RBUF(4) 737C 738C Draw a straight line segment from absolute pixel coordinates (RBUF(1), 739C RBUF(2)) to (RBUF(3), RBUF(4)). The line either overwrites (sets to 740C black) or erases (sets to white) the previous contents of the bitmap, 741C depending on the current color index. Setting bits is accomplished 742C with a VMS BISB2 instruction, expressed in Fortran as .OR.; clearing 743C bits is accomplished with a VMS BICB2 instruction, expressed in 744C Fortran as .AND. .NOT.. The line is generated with a Simple Digital 745C Differential Analyser (ref: Newman & Sproull). 746C 747C Arguments: 748C 749C LINE I I =0 for dot, =1 for line. 750C RBUF(1),RBUF(2) I R Starting point of line. 751C RBUF(3),RBUF(4) I R Ending point of line. 752C ICOL I I =0 for erase, =1 for write. 753C BITMAP I/O B (address of) the frame buffer. 754C 755C----------------------------------------------------------------------- 756 BYTE QMASK(0 : 7) 757C! INTEGER*1 QMASK(0 : 7) 758 INTEGER*4 K, KX, KY, LENGTH 759 REAL*4 D, XINC, XP, YINC, YP 760 DATA QMASK /'80'X, '40'X, '20'X, '10'X, 761 1 '08'X, '04'X, '02'X, '01'X/ 762C! DATA QMASK /16#80, 16#40, 16#20, 16#10, 763C! 1 16#08, 16#04, 16#02, 16#01/ 764C----------------------------------------------------------------------- 765 IF (LINE .GT. 0) THEN 766 D = MAX (ABS (RBUF(3) - RBUF(1)), ABS (RBUF(4) - RBUF(2))) 767 LENGTH = D 768 IF (LENGTH .EQ. 0) THEN 769 XINC = 0.0 770 YINC = 0.0 771 ELSE 772 XINC = (RBUF(3) - RBUF(1)) / D 773 YINC = (RBUF(4) - RBUF(2)) / D 774 END IF 775 ELSE 776 LENGTH = 0 777 XINC = 0.0 778 YINC = 0.0 779 END IF 780 XP = RBUF(1) + 0.5 781 YP = RBUF(2) + 0.5 782 IF (ICOL .NE. 0) THEN 783 DO K = 0, LENGTH 784 KX = XP 785 KY = (BY - 1) - INT (YP) 786 BITMAP(KX / 8 + 1, KY + 1) = BITMAP(KX / 8 + 1, KY + 1) .OR. 787 1 QMASK(MOD (KX, 8)) 788 XP = XP + XINC 789 YP = YP + YINC 790 END DO 791 ELSE 792 DO K = 0,LENGTH 793 KX = XP 794 KY = (BY - 1) - INT (YP) 795 BITMAP(KX / 8 + 1, KY + 1) = BITMAP(KX / 8 + 1, KY + 1) 796 1 .AND. (.NOT. QMASK(MOD (KX, 8))) 797 XP = XP + XINC 798 YP = YP + YINC 799 END DO 800 END IF 801C----------------------------------------------------------------------- 802 RETURN 803 END 804 805C*GRHJ01 -- PGPLOT LaserJet driver, copy bitmap to output file 806C+ 807 SUBROUTINE GRHJ01 (LUN, BX, BY, BITMAP) 808 INTEGER BX, BY, LUN 809 BYTE BITMAP(BX, BY) 810C! INTEGER*1 BITMAP(BX, BY) 811C 812C Arguments: 813C 814C LUN (input) Fortran unit number for output 815C BX, BY (input) dimensions of BITMAP 816C BITMAP (input) the bitmap array 817C----------------------------------------------------------------------- 818 BYTE ESC 819C! INTEGER*1 ESC 820 INTEGER I, J, K 821 CHARACTER KSTR*3 822 PARAMETER (ESC = 27) 823C----------------------------------------------------------------------- 824C Start graphics mode 825 WRITE (LUN) ESC, '*r1A' 826C Loop through bitmap 827 DO J = 1, BY 828C Search for last non-NUL 829 DO K = BX, 2, -1 830 IF (BITMAP(K, J) .NE. 0) GO TO 10 831 END DO 832C Guarantee that we know what K 833C is after loop. 834C (Remember FORTRAN IV!?) 835 K = 1 836C Encode length of line 837 10 WRITE (KSTR, '(I3.3)') K 838C Write out the raster line 839 WRITE (LUN) ESC, '*b', KSTR, 'W', (BITMAP(I, J), I = 1, K) 840 END DO 841C Turn off graphics mode. 842 WRITE (LUN) ESC, '*rB' 843C----------------------------------------------------------------------- 844 RETURN 845 END 846 847C*GRHJ02 -- PGPLOT LaserJet+ driver, dump bitmap to device 848C+ 849 SUBROUTINE GRHJ02 (LUN, BX, BY, BITMAP, TEX) 850 LOGICAL TEX 851 INTEGER LUN, BX, BY 852 BYTE BITMAP(BX, BY) 853C! INTEGER*1 BITMAP(BX, BY) 854C 855C Output raster for this page. This routine has been optimised to 856C minimize the memory usage in the LaserJet. This sometimes leads to a 857C larger file than if a straight bitmap approach had been used. 858C 859C NOTE: This subroutine is a kludge to make a 512K LaserJet produce 860C full page plots at 300dpi. It will not always produce the plot 861C on one page. If you overrun the memory restrictions, two pages 862C will be printed, each containing parts of the plot. One must 863C then resort to cut and paste techniques to restore the plot. 864C Most simple line graphs do not come close to the memory limit, 865C but sometimes a messy contour plot will. DON'T EVEN THINK 866C ABOUT SENDING A GREYSCALE TO THIS SUBROUTINE! 867C 868C Arguments: 869C 870C LUN I I Logical unit number of output file 871C BX, BY I I Dimensions of frame buffer 872C BITMAP I/O B (address of) the frame buffer. 873C 874C Version 1.0 03-Sep-1986 S. C. Allendorf 875C Version 2.0 08-Dec-1986 S. C. Allendorf Use relative positioning 876C Version 2.1 28-Dec-1986 S. C. Allendorf Optimize positioning code 877C Version 3.0 02-Jan-1987 S. C. Allendorf Add code for rules 878C VERSION 3.1 10-FEB-1988 S. C. Allendorf Attempt to speed up code 879C----------------------------------------------------------------------- 880 BYTE ESC, N0 881C! INTEGER*1 ESC, N0 882 LOGICAL NOBIT 883 INTEGER*4 CNUM, CONUM, CURCOL, CURROW, FB(35), FB2(25), I, IPOS 884 INTEGER*4 IYOFF, J, K, L, M, N, NB(35), NBNUM, NBTOT, NBNUM2 885 INTEGER*4 NB2(25), RNUM, RONUM, GRHJ03 886 CHARACTER ALLONE*300, COL*5, NBYTE*4, NULLS*(10), ROW*5, X*300 887 PARAMETER (N0 = 0) 888 PARAMETER (ESC = 27) 889C----------------------------------------------------------------------- 890C Define some useful constants 891 IF (TEX) THEN 892 IYOFF = 0 893 ELSE 894 IYOFF = 75 895 END IF 896 DO J = 1, 10 897 NULLS(J:J) = CHAR (0) 898 END DO 899 DO J = 1, 300 900 ALLONE(J:J) = CHAR (255) 901 END DO 902C Initialize some variables 903 CURCOL = 0 904 CURROW = 0 905C Position the cursor 906 IF (.NOT. TEX) THEN 907 WRITE (LUN) ESC, '*p0y0X' 908 END IF 909C Set up vertical rule height 910 WRITE (LUN) ESC, '*c1B' 911C Write out each line on page 912 DO K = 1, BY 913C Copy raster to buffer and find 914C the beginning and end of the 915C bitmap line 916 NOBIT = .TRUE. 917 NBTOT = 0 918 FB(1) = BX 919 DO J = 1, BX 920 X(J:J) = CHAR (BITMAP(J,K)) 921 IF (X(J:J) .NE. NULLS(1:1)) THEN 922 NOBIT = .FALSE. 923 NBTOT = J 924 FB(1) = MIN (FB(1), J) 925 END IF 926 END DO 927C Break line into pieces 928 IF (.NOT. NOBIT) THEN 929 L = 1 930 GO TO 20 931 10 NB(L) = FB(L) + IPOS - 2 932 L = L + 1 933C Search for first non-null 934 DO J = NB(L-1) + 11, NBTOT 935 IF (X(J:J) .NE. NULLS(1:1)) THEN 936 FB(L) = J 937 GO TO 20 938 END IF 939 END DO 940C Search for a string of nulls 941 20 IPOS = INDEX (X(FB(L):NBTOT), NULLS) 942 IF (IPOS .EQ. 0) THEN 943 NB(L) = NBTOT 944 GO TO 30 945 ELSE 946 GO TO 10 947 END IF 948C Loop through each substring 949 30 DO J = 1, L 950C Search for rules 951 M = 1 952 FB2(1) = FB(J) 953 GO TO 50 954 40 IF (IPOS .NE. 1) THEN 955 NB2(M) = 0 956 DO I = FB2(M), FB2(M) + IPOS - 2 957 IF (X(I:I) .NE. NULLS(1:1)) THEN 958 NB2(M) = MAX (FB2(M), I) 959 END IF 960 END DO 961 M = M + 1 962 FB2(M) = FB2(M-1) + IPOS - 1 963 IF (NB2(M-1) .EQ. 0) THEN 964 FB2(M-1) = FB2(M) 965 M = M - 1 966 END IF 967 END IF 968C Search for first non-<XFF> 969 DO N = FB2(M) + 25, NB(J) 970 IF (X(N:N) .NE. ALLONE(1:1)) THEN 971 NB2(M) = N - 1 972 M = M + 1 973 FB2(M) = N 974 GO TO 50 975 END IF 976 END DO 977 NB2(M) = NB(J) 978 GO TO 60 979C Search for a string of <XFF>s 980 50 IPOS = INDEX (X(FB2(M):NB(J)), ALLONE(1:25)) 981 IF (IPOS .EQ. 0) THEN 982 NB2(M) = NB(J) 983 GO TO 60 984 ELSE 985 GO TO 40 986 END IF 987C Print each of the substrings 988 60 DO I = 1, M 989C Get the number of bytes 990 NBNUM = NB2(I) - FB2(I) + 1 991 WRITE (NBYTE, 1000) NBNUM 992 NBNUM2 = GRHJ03 (NBNUM) 993C Calculate the row and column 994 RONUM = K + IYOFF 995 CONUM = (FB2(I) - 1) * 8 996C Determine the positioning 997C sequence and write it out 998 IF (RONUM .NE. CURROW .AND. CONUM .NE. CURCOL) THEN 999 RNUM = RONUM - CURROW 1000 CNUM = CONUM - CURCOL 1001 WRITE (ROW, 1010) RNUM 1002 WRITE (COL, 1010) CNUM 1003 RNUM = GRHJ03 (ABS (RNUM)) + 1 1004 CNUM = GRHJ03 (ABS (CNUM)) + 1 1005 WRITE (LUN) ESC, '*p', ROW(6-RNUM:5), 'y', 1006 + COL(6-CNUM:5), 'X' 1007 ELSE IF (RONUM .NE. CURROW) THEN 1008 RNUM = RONUM - CURROW 1009 WRITE (ROW, 1010) RNUM 1010 RNUM = GRHJ03 (ABS (RNUM)) + 1 1011 WRITE (LUN) ESC, '*p', ROW(6-RNUM:5), 'Y' 1012 ELSE IF (CONUM .NE. CURCOL) THEN 1013 CNUM = CONUM - CURCOL 1014 WRITE (COL, 1010) CNUM 1015 CNUM = GRHJ03 (ABS (CNUM)) + 1 1016 WRITE (LUN) ESC, '*p', COL(6-CNUM:5), 'X' 1017 END IF 1018C Check for all bits set in 1019C substring 1020 IF ((INDEX (X(FB2(I):NB2(I)), ALLONE(1:NBNUM)) .EQ. 1) 1021 + .AND. NBNUM .GE. 5) THEN 1022 NBNUM = NBNUM * 8 1023 WRITE (NBYTE, 1000) NBNUM 1024 NBNUM2 = GRHJ03 (NBNUM) 1025 WRITE (LUN) ESC, '*c', NBYTE(5-NBNUM2:4), 'A' 1026 WRITE (LUN) ESC, '*c0P' 1027 CURROW = RONUM 1028 CURCOL = CONUM 1029 ELSE 1030C Write out raster line 1031 WRITE (LUN) ESC, '*r1A' 1032 WRITE (LUN) ESC, '*b', NBYTE(5-NBNUM2:4), 'W', 1033 + X(FB2(I):NB2(I)) 1034 WRITE (LUN) ESC, '*rB' 1035 CURROW = RONUM + 1 1036 CURCOL = CONUM 1037 END IF 1038 END DO 1039 END DO 1040 END IF 1041 END DO 1042C----------------------------------------------------------------------- 1043 1000 FORMAT (I4.4) 1044 1010 FORMAT (SP,I5) 1045 RETURN 1046 END 1047 1048C*GRHJ03 -- PGPLOT LaserJet+ driver, calculate length of an integer 1049C+ 1050 INTEGER FUNCTION GRHJ03 (I) 1051 INTEGER I 1052C 1053C This function calculates the number of digits in a supplied integer. 1054C 1055C Arguments: 1056C 1057C I I I Integer value of number 1058C GRHJ03 O I Length of printed representation of I 1059C 1060C Version 1.0 10-Feb-1988 S. C. Allendorf 1061C----------------------------------------------------------------------- 1062 IF (I .GE. 10) THEN 1063 IF (I .GE. 100) THEN 1064 IF (I .GE. 1000) THEN 1065 GRHJ03 = 4 1066 ELSE 1067 GRHJ03 = 3 1068 END IF 1069 ELSE 1070 GRHJ03 = 2 1071 END IF 1072 ELSE 1073 GRHJ03 = 1 1074 END IF 1075C----------------------------------------------------------------------- 1076 RETURN 1077 END 1078 1079C*GRHJ04 -- PGPLOT LaserJet driver, copy bitmap to output file with 1080C compression -- for DESKJET PLUS and possibly other printers 1081C+ 1082 SUBROUTINE GRHJ04 (LUN, BX, BY, BITMAP) 1083 INTEGER BX, BY, LUN 1084 BYTE BITMAP(BX, BY) 1085C! INTEGER*1 BITMAP(BX, BY) 1086C 1087C Arguments: 1088C 1089C LUN (input) Fortran unit number for output 1090C BX, BY (input) dimensions of BITMAP 1091C BITMAP (input) the bitmap array 1092C----------------------------------------------------------------------- 1093 BYTE ESC 1094C! INTEGER*1 ESC 1095 INTEGER K1, J, K, BXMAX,BXMIN 1096 CHARACTER KSTR*3 1097 PARAMETER (ESC = 27) 1098 CHARACTER*10 BUFF1 1099C! integer*1 BUFF2(400) 1100 byte BUFF2(400) 1101 integer lbuf1,lbuf2,tbuf 1102 byte tbufb(2) 1103 equivalence (tbuf,tbufb) 1104C----------------------------------------------------------------------- 1105C Start graphics mode 1106 WRITE (LUN) ESC, '*r1A' 1107C Loop through bitmap 1108 DO J = 1, BY 1109C Search for last non-NUL 1110 DO K = BX, 2, -1 1111 IF (BITMAP(K, J) .NE. 0) GO TO 10 1112 END DO 1113C Guarantee that we know what K 1114C is after loop. 1115C (Remember FORTRAN IV!?) 1116 K = 1 111710 BXMAX = K 1118 BXMIN = 1 1119 K = 1 1120 BUFF1(1:1) = CHAR(27) 1121 BUFF1(2:5) = '*b2m' 1122 lbuf1 = 5 1123C If there are less than 4 bytes don't bother with an offset 1124 IF (BXMAX .LE. 4) GOTO 25 1125C Count the number of Zero bits at beginning of line 1126 DO K = BXMIN,BXMAX-1 1127 IF (BITMAP(K, J) .NE. 0) GO TO 20 1128 ENDDO 1129 K = BXMAX 113020 IF (K .GT. 4) THEN 1131 K1 = (K-1)*8 1132 BXMIN = K 1133 IF (K1 .LE. 9) THEN 1134 LBUF1 = 7 1135 WRITE (BUFF1(6:LBUF1),'(I1.1,A1)') K1,'x' 1136 ELSEIF (K1 .LE. 99) THEN 1137 LBUF1 = 8 1138 WRITE (BUFF1(6:LBUF1),'(I2.2,A1)') K1,'x' 1139 ELSEIF (K1 .LE. 999) THEN 1140 LBUF1 = 9 1141 WRITE (BUFF1(6:LBUF1),'(I3.3,A1)') K1,'x' 1142 ELSE 1143 LBUF1 = 10 1144 WRITE (BUFF1(6:LBUF1),'(I4.4,A1)') K1,'x' 1145 ENDIF 1146 ENDIF 1147 114825 WRITE (LUN) BUFF1(1:LBUF1) 1149 1150 lbuf2 = 1 1151 115230 CONTINUE 1153 DO K = BXMIN,BXMAX 1154 IF (K .GE. BXMAX-2) THEN 1155C we are at the end of the bit-map, 1156C N.B. BXMAX - BXMIN will be less than 128 1157 buff2(lbuf2) = BXMAX - BXMIN 1158 lbuf2 = lbuf2 + 1 1159 DO K1=BXMIN,BXMAX 1160 buff2(lbuf2) = BITMAP(K1, J) 1161 lbuf2 = lbuf2 + 1 1162 ENDDO 1163 GOTO 100 1164 ELSEIF (K - BXMIN .GE. 125) THEN 1165C we have 126 non-repeated characters 1166 buff2(lbuf2) = K - BXMIN 1167 lbuf2 = lbuf2 + 1 1168 DO K1=BXMIN,K 1169 buff2(lbuf2) = BITMAP(K1, J) 1170 lbuf2 = lbuf2 + 1 1171 ENDDO 1172 BXMIN = K+1 1173 IF (BXMIN .GT. BXMAX) GOTO 100 1174 GOTO 30 1175 ELSEIF (BITMAP(K, J) .EQ. BITMAP(K+1, J) .AND. 1176 1 BITMAP(K, J) .EQ. BITMAP(K+2, J)) THEN 1177C we have 2 or more repeated characters 1178 IF (K .gt. BXMIN) THEN 1179C write out non-repeated characters, if any 1180 buff2(lbuf2) = K - BXMIN - 1 1181 lbuf2 = lbuf2 + 1 1182 DO K1=BXMIN,K-1 1183 buff2(lbuf2) = BITMAP(K1, J) 1184 lbuf2 = lbuf2 + 1 1185 ENDDO 1186 ENDIF 1187C count the number of repeated characters, up to 127 1188 DO K1=K+3,MIN(BXMAX,K+127) 1189 IF (BITMAP(K, J) .NE. BITMAP(K1, J)) GOTO 40 1190 ENDDO 1191 K1 = BXMAX + 1 1192C write out repeated characters 119340 CONTINUE 1194C! VAX version: 1195 Tbuf = 257 - K1 + K 1196 buff2(lbuf2) = tbufb(1) 1197C PC version: 1198C! buff2(lbuf2) = 257 - (K1 - K) 1199 lbuf2 = lbuf2 + 1 1200 buff2(lbuf2) = BITMAP(K, J) 1201 lbuf2 = lbuf2 + 1 1202 BXMIN = K1 1203 IF (BXMIN .GT. BXMAX) GOTO 100 1204 GOTO 30 1205 ENDIF 1206 ENDDO 1207100 WRITE (KSTR, '(I3.3)') lbuf2-1 1208 IF (lbuf2 .LE. 10) THEN 1209 WRITE (LUN) KSTR(3:3), 'W', (BUFF2(k1),k1=1,lbuf2-1) 1210 ELSEIF (lbuf2 .LE. 100) THEN 1211 WRITE (LUN) KSTR(2:3), 'W', (BUFF2(k1),k1=1,lbuf2-1) 1212 ELSE 1213 WRITE (LUN) KSTR(1:3), 'W', (BUFF2(k1),k1=1,lbuf2-1) 1214 ENDIF 1215C Write out the raster line 1216 END DO 1217C Turn off graphics mode. 1218 WRITE (LUN) ESC, '*rB' 1219C----------------------------------------------------------------------- 1220 RETURN 1221 END 1222 1223C*GRHJ05 -- zero fill buffer 1224C+ 1225 SUBROUTINE GRHJ05 (BUFSIZ,BUFFER) 1226C 1227C Arguments: 1228C 1229C BUFFER (byte array, input): (address of) the buffer. 1230C BUFSIZ (integer, input): number of bytes in BUFFER. 1231C----------------------------------------------------------------------- 1232 INTEGER BUFSIZ, I 1233 BYTE BUFFER(BUFSIZ), FILL 1234 DATA FILL/0/ 1235C 1236 DO 10 I=1,BUFSIZ 1237 BUFFER(I) = FILL 1238 10 CONTINUE 1239 END 1240