1C*LNDRIV PGPLOT DRIVER FOR DIGITAL LN03 (LANDSCAPE) 2 SUBROUTINE LNDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) 3 INTEGER IFUNC, NBUF, LCHR 4 REAL RBUF(*) 5 CHARACTER*(*) CHR 6C----------------------------------------------------------------------- 7C PGPLOT driver for Digital LN03 Laser Printer (landscape) 8C File : LNDRIVER.FOR 9C----------------------------------------------------------------------- 10C Version 1.0 - 1989 Nov. Sid Penstone, Queen's University 11C Last Revision Dec.1,1989, added direct code for vertical lines, 12C now do dots as a case of a zero length vector 13C----------------------------------------------------------------------- 14C This routine has been written specifically for the LN03-PLUS 15C Laser Printer 16C 17C Name: '/LN03' 18C In all case, the initialization sequences are written out, 19C whether or not the plotter is connected as a terminal, 20C or driven from an intermediate file. 21C 22C If there is more than one plot 23C the page is ejected before the next one 24C 25C ref: Digital LN03 Programmer Reference Manual, P/N EK-OLN03-002, 26C and Digital LN03-Plus " " " P/N EK-LN03S-001 27C 28C We end up with a 9" by 7" display area. 29C 30C----------------------------------------------------------------------- 31 CHARACTER*(*) TYPE 32 PARAMETER (TYPE='LN03 (Digital LN03 Laser Printer, landscape)') 33C 34 INTEGER MARGIN, NXPIX, NYPIX, NSIXROWS, NSIXCOLS 35 PARAMETER(MARGIN=150) 36 PARAMETER(NXPIX=3000) 37 PARAMETER(NYPIX=2400) 38 PARAMETER(NSIXROWS=(NYPIX/6)+2) 39 PARAMETER(NSIXCOLS=NXPIX) 40 CHARACTER*10 MSG 41 INTEGER WIDTH,XLEFT,XRIGHT,YBOT,YTOP, INTENS, XMAX, YMAX, XMIN 42 INTEGER UNIT, IER 43 INTEGER I0, J0, I1, J1 44 INTEGER IK1, IK2, IK3, IK4, IK5, PLOTNO 45 CHARACTER*1 ESC 46 DATA XLEFT,XRIGHT,YTOP,YBOT/0,NXPIX,0,NYPIX/ 47 DATA ESC /27/ 48 DATA WIDTH /2/ 49 LOGICAL ACTIVE(0:NSIXROWS) 50C Data for the allocation routines 51 INTEGER GRGMEM, GRFMEM 52 INTEGER BUFLEN, IPOINTS, IERR 53 LOGICAL ALLOC 54 SAVE BUFLEN, IPOINTS, ALLOC 55 DATA ALLOC /.FALSE./ 56 DATA IPOINTS /-1/ 57C for debugging 58 LOGICAL DEBUG 59 DATA DEBUG/.FALSE./ 60 61C----------------------------------------------------------------------- 62C 63 GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, 64 1 110,120,130,140,150,160,170,180,190,200, 65 2 210,220,230), IFUNC 66 GOTO 900 67C 68C--- IFUNC = 1, Return device name.------------------------------------- 69C 7010 CHR = TYPE 71 LCHR = LEN(TYPE) 72 RETURN 73C 74C--- IFUNC = 2, Return physical min and max for plot device, and range 75C of color indices.--------------------------------------- 76C 7720 RBUF(1) = 0 78 RBUF(2) = NXPIX - 2*MARGIN 79 RBUF(3) = 0 80 RBUF(4) = NYPIX - 2*MARGIN 81 RBUF(5) = 0 82 RBUF(6) = 1 83 NBUF = 6 84 RETURN 85C 86C--- IFUNC = 3, Return device resolution. ------------------------------ 87C 8830 RBUF(1) = 300.0 89 RBUF(2) = 300.0 90 RBUF(3) = WIDTH 91 NBUF = 3 92 RETURN 93C 94C--- IFUNC = 4, Return misc device info. ------------------------------- 95C (This device is Hardcopy, No cursor, No dashed lines, No area fill, 96C No thick lines) 97C 9840 CHR = 'HNNNNNNNNN' 99 LCHR = 10 100 RETURN 101C 102C--- IFUNC = 5, Return default file name. ------------------------------ 103C 10450 CHR = 'PGPLOT.LN3' 105 LCHR = 11 106 RETURN 107C 108C--- IFUNC = 6, Return default physical size of plot. ------------------ 109C 11060 RBUF(1) = 0 111 RBUF(2) = NXPIX-2*MARGIN 112 RBUF(3) = 0 113 RBUF(4) = NYPIX-2*MARGIN 114 NBUF = 4 115 RETURN 116C 117C--- IFUNC = 7, Return misc defaults. ---------------------------------- 118C 11970 RBUF(1) = 10 120 NBUF = 1 121 RETURN 122C 123C--- IFUNC = 8, Select plot. ------------------------------------------- 124C 12580 CONTINUE 126 RETURN 127C 128C--- IFUNC = 9, Open workstation. -------------------------------------- 129C 13090 CONTINUE 131C Try to open the graphics device 132 CALL GRGLUN(UNIT) 133 OPEN (UNIT=UNIT,FILE=CHR(:LCHR),STATUS='NEW', 134 1 FORM='FORMATTED', CARRIAGECONTROL='LIST', 135 1 RECL=512,IOSTAT=IER) 136 IF (IER.NE.0) THEN 137 CALL ERRSNS(IK1,IK2,IK3,IK4,IK5) 138 CALL GRWARN('Cannot open graphics device ' 139 1 //CHR(1:LCHR)) 140 IF (IK2.NE.0 .AND. IK2.NE.1) CALL GRGMSG(IK2) 141 IF (IK5.NE.0 .AND. IK5.NE.1) CALL GRGMSG(IK5) 142 RBUF(2) = 0 143 RETURN 144 ENDIF 145 RBUF(1) = UNIT 146 RBUF(2) = 1 147 NBUF = 2 148C Now allocate the bitmap buffers (Assume integer*2) 149 IF (.NOT. ALLOC) THEN 150 BUFLEN = NSIXROWS * NSIXCOLS 151 IERR = GRGMEM(2*BUFLEN, IPOINTS) 152 IF (IERR .NE. 1 ) THEN 153 CALL GRGMSG(IERR) 154 CALL GRWARN('Memory allocation failure') 155 RETURN 156 ENDIF 157 ALLOC = .TRUE. 158 ENDIF 159C Digital says that the allocated memory may not be zeroed: 160C Clear the row flags (and the bit map) 161 CALL LN03_CLEAR(%VAL(IPOINTS),BUFLEN,ACTIVE,NSIXROWS) 162C 163C always write the preamble 164C this resets the plotter 165 WRITE (UNIT, '(A)') ESC//'c' 166C this sets it for landscape, origin at corner 167 WRITE (UNIT, '(A)') ESC//'[?21 J' 168 PLOTNO = 0 169 RETURN 170C 171C--- IFUNC=10, Close workstation. -------------------------------------- 172 100 CONTINUE 173C always turn it off 174 CLOSE (UNIT) 175 CALL GRFLUN(UNIT) 176C Deallocate the buffer 177 IF (ALLOC .OR. IPOINTS .GE. 0) THEN 178 IERR = GRFMEM(2*BUFLEN, IPOINTS) 179 IF (IERR .NE. 1 ) THEN 180 CALL GRGMSG(IERR) 181 CALL GRWARN('Deallocation failure') 182 RETURN 183 ENDIF 184 ALLOC = .FALSE. 185 IPOINTS = -1 186 ENDIF 187 RETURN 188C 189C--- IFUNC=11, Begin picture. ------------------------------------------ 190C 191 110 CONTINUE 192C WE COULD GET THE VALUE OF XMAX AND YMAX HERE 193 YMAX = YBOT - 2*MARGIN 194 XMIN = XLEFT + MARGIN 195 XMAX = XRIGHT - MARGIN 196 PLOTNO = PLOTNO + 1 197 RETURN 198C 199C--- IFUNC=12, Draw line. ---------------------------------------------- 200C 201 120 CONTINUE 202 I0 = XMIN + NINT(RBUF(1)) 203 J0 = YMAX - NINT(RBUF(2)) 204 I1 = XMIN + NINT(RBUF(3)) 205 J1 = YMAX - NINT(RBUF(4)) 206 CALL LN03_VECTOR(I0,J0,I1,J1,WIDTH,XLEFT,XRIGHT, 207 1 YTOP,YBOT,%val(IPOINTS),ACTIVE,NSIXROWS,NSIXCOLS,INTENS) 208 RETURN 209C 210C--- IFUNC=13, Draw dot. ----------------------------------------------- 211C 212 130 CONTINUE 213 I0 = XMIN + NINT(RBUF(1)) 214 J0 = YMAX - NINT(RBUF(2)) 215 CALL LN03_VECTOR(I0,J0,I0,J0,WIDTH,XLEFT,XRIGHT, 216 1 YTOP,YBOT,%VAL(IPOINTS),ACTIVE,NSIXROWS,NSIXCOLS,INTENS) 217 RETURN 218C 219C--- IFUNC=14, End picture. -------------------------------------------- 220C 221 140 CONTINUE 222 CALL LN03_DUMP(UNIT,XLEFT,XMAX+WIDTH,YTOP+MARGIN,YMAX+WIDTH, 223 1%val(IPOINTS),ACTIVE,NSIXROWS,NSIXCOLS) 224C Clear the bitmap buffer 225 IF (ALLOC) THEN 226 CALL LN03_CLEAR(%val(IPOINTS),BUFLEN,ACTIVE,NSIXROWS) 227 ENDIF 228C Eject the paper with a form feed 229C WRITE (UNIT, '(A)') CHAR(12) 230 RETURN 231C 232C--- IFUNC=15, Select color index. ------------------------------------- 233C 234 150 INTENS = NINT(RBUF(1)) 235 IF (INTENS .GT.1) INTENS = 1 236 if (debug) write(0,'(A,G13.7,I6)')'Intens= ',RBUF(1),INTENS 237 RETURN 238C 239C--- IFUNC=16, Flush buffer. ------------------------------------------- 240C (Null operation: buffering is not implemented.) 241C 242160 CONTINUE 243 RETURN 244C 245C--- IFUNC=17, Read cursor. -------------------------------------------- 246C (Not implemented: should not be called.) 247C 248170 GOTO 900 249C 250C--- IFUNC=18, Erase alpha screen. ------------------------------------- 251C (Null operation: there is no alpha screen.) 252C 253180 CONTINUE 254 RETURN 255C 256C--- IFUNC=19, Set line style. ----------------------------------------- 257C (Not implemented: should not be called.) 258C 259190 GOTO 900 260C 261C--- IFUNC=20, Polygon fill. ------------------------------------------- 262C (Not implemented: should not be called.) 263C 264200 GOTO 900 265C 266C--- IFUNC=21, Set color representation. ------------------------------- 267C 268210 RETURN 269C Other colors are not implemented 270C 271C 272C--- IFUNC=22, Set line width. ----------------------------------------- 273C (Not implemented: should not be called.) 274C 275220 GOTO 900 276C 277C--- IFUNC=23, Escape. ------------------------------------------------- 278C 279230 CONTINUE 280 WRITE (UNIT, '(A)') CHR(:LCHR) 281 RETURN 282C----------------------------------------------------------------------- 283C Error: unimplemented function. 284C 285 900 WRITE (MSG,'(I10)') IFUNC 286 CALL GRWARN('Unimplemented function in LN03 device driver: '//MSG) 287 NBUF = -1 288 RETURN 289C----------------------------------------------------------------------- 290 END 291 292C------------------- PRIMITIVE LN03 FUNCTIONS ------------------- 293C 294C---------------------------------------------------------------- 295C CLEAR THE BITMAP IF IT WAS USED BEFORE 296C 297 SUBROUTINE LN03_CLEAR(BUFF,N,BUSY,NR) 298 INTEGER*2 BUFF(0:*) 299 LOGICAL BUSY(0:*) 300 INTEGER N, I , NR 301 DO 1 I = 0, N-1 3021 BUFF(I) = 0 303 DO 2 I = 0, NR-1 3042 BUSY(I) = .FALSE. 305 RETURN 306 END 307 308 309C--------------------------------------------------------------------- 310 CHARACTER*10 FUNCTION LN03_PACK(IARG,IP) 311C----------------------------------------------------------------------- 312C (Internal routine, LN): Identical to the grgl00() routine 313C This subroutine translates the argument IARG into a character 314C string and then returns the position of the first non-blank 315C character in the string 316C Arguments: IARG 317C IP (returned) 318C----------------------------------------------------------------------- 319 INTEGER IARG, IP 320C 321 LN03_PACK = ' ' 322 IP = 10 323 WRITE(LN03_PACK,'(I10)') IARG 324 DO IP=1,10 325 IF (LN03_PACK(IP:IP) .NE. ' ') RETURN 326 ENDDO 327 END 328 329 330C---------------------------- VECTOR DRAWING -------------------------- 331 SUBROUTINE LN03_VECTOR(X1,Y1,X2,Y2,WIDTH,XLEFT,XRIGHT, 332 1 YTOP,YBOT,POINTS,ACTIVE,NSIXROWS,NSIXCOLS,INTENS) 333C---------------------------------------------------------------------- 334C 335C Based on Bresenham's algorithm, and a C version written by 336C Paul Demone, Canadian Microelectronics Corporation 337C 338C We enter with the values x,y converted to internal values 339C That is, we have reflected the direction of Y 340C 341 342 INTEGER X1,Y1,X2,Y2,WIDTH,XLEFT,XRIGHT,YBOT,YTOP,NSIXCOLS, 343 1 NSIXROWS, INTENS 344 INTEGER X, Y, DX, DY, ADX, ADY, E, DA, DB, D1X, D1Y, D2X, D2Y 345 INTEGER XX, YY, INDX, ITEMP 346 INTEGER*2 SHIFT 347 INTEGER*2 POINTS(0:*) 348 LOGICAL ACTIVE(0:*) 349 logical debug 350 data debug /.false./ 351 352C if (debug) write(0,'(A,I6,I6)')'INTENS= ',INTENS 353C Start at X1, Y1 354 if(debug)write(0, '(A,4(I6),A,I3,A,2(I10))')'LINE: ', 355 1x1,y1,x2,y2,'INTENS=',INTENS,' ROW,COL: ', 356 1 (Y1/6),((Y1/6)*NSIXCOLS+X1) 357C Note that we always try to move the X index inside the loops, since they 358C are adjacent in the bitmap array 359C If this is a horizontal line, then we can do it faster 360 IF (Y2 .EQ. Y1) THEN 361 IF(X2 .LT. X1) THEN 362 ITEMP = X1 363 X1 = X2 364 X2 = ITEMP 365 ENDIF 366 YY = Y1 367 DO WHILE (YY .LT. Y1 + WIDTH .AND. YY .LT. YBOT) 368 INDX = (YY/6)*NSIXCOLS 369 SHIFT = JMOD(YY, 6) 370 XX = X1 371 DO WHILE ( XX .LT. X2 + WIDTH .AND. XX .LT. XRIGHT) 372 IF (INTENS .EQ. 0) THEN 373 POINTS(INDX + XX) = IIBCLR(POINTS(INDX +XX), SHIFT) 374 ELSE 375 POINTS(INDX + XX) = IIBSET(POINTS(INDX +XX), SHIFT) 376 ENDIF 377 XX = XX + 1 378 ENDDO 379 IF (INTENS .NE. 0) ACTIVE(YY/6) = .TRUE. 380 YY = YY + 1 381 ENDDO 382 RETURN 383C Might be a vertical line: 384 ELSEIF (X2. EQ. X1) THEN 385 IF (Y2 .LT. Y1) THEN 386 ITEMP = Y1 387 Y1 = Y2 388 Y2 = ITEMP 389 ENDIF 390 YY = Y1 391 DO WHILE (YY .LT. Y2 + WIDTH .AND. YY .LT. YBOT) 392 INDX = (YY/6)*NSIXCOLS 393 SHIFT = JMOD(YY, 6) 394 XX = X1 395 DO WHILE ( XX .LT. X1 + WIDTH .AND. XX .LT. XRIGHT) 396 IF (INTENS .EQ. 0) THEN 397 POINTS(INDX + XX) = IIBCLR(POINTS(INDX +XX), SHIFT) 398 ELSE 399 POINTS(INDX + XX) = IIBSET(POINTS(INDX +XX), SHIFT) 400 ENDIF 401 XX = XX + 1 402 ENDDO 403 IF (INTENS .NE. 0) ACTIVE(YY/6) = .TRUE. 404 YY = YY + 1 405 ENDDO 406 RETURN 407 ENDIF 408C It is a vector : Use the algorithm 409 410 DX = X2 - X1 411 DY = Y2 - Y1 412 D2X = ISIGN(1,DX) 413 D2Y = ISIGN(1,DY) 414 ADX = IABS(DX) 415 ADY = IABS(DY) 416C Check for the maximum number of steps: X or Y ? 417 IF (ADX .GT. ADY) THEN 418 DA = ADX 419 DB = ADY 420 D1Y = 0 421 D1X = ISIGN(1,DX) 422 ELSE 423 DA = ADY 424 DB = ADX 425 D1X = 0 426 D1Y = ISIGN(1,DY) 427 ENDIF 428 DB = 2*DB 429 E = DB - DA 430 DA = 2*DA 431 X = X1 432 Y = Y1 433C Here we will be using some VAX Fortran extensions ....... 434 800 CONTINUE 435C DO WHILE (.TRUE.) 436 IF (X .GE. XLEFT .AND. Y .GE. YTOP .AND. 437 1 X .LT. XRIGHT .AND. Y .LT. YBOT) THEN 438C Don't come in here if we are already off scale ! 439C If it is ok, then add a cluster of pixels of size width by width 440C if(debug)write(0, '(4(I6))')x,y 441 XX = X 442 DO WHILE (XX .LT. X+WIDTH .AND. XX .LT. XRIGHT) 443 YY = Y 444 DO WHILE(YY .LT. Y+WIDTH .AND. YY .LT. YBOT) 445 INDX = (YY/6)*NSIXCOLS + XX 446 SHIFT = JMOD(YY,6) 447C IF(DEBUG)WRITE(UNIT,'(2(I6),I10,6(I6))') 448C 1 XX,YY,INDX,POINTS(INDX),INTENS,SHIFT 449 IF (INTENS .EQ. 0) THEN 450 POINTS(INDX) = IIBCLR(POINTS(INDX),SHIFT) 451 ELSE 452 POINTS(INDX) = IIBSET(POINTS(INDX),SHIFT) 453 ACTIVE(YY/6) = .TRUE. 454 ENDIF 455 YY = YY + 1 456 ENDDO 457 XX = XX +1 458 ENDDO 459 ENDIF 460C Are we finished ? 461 IF (X .EQ. X2 .AND. Y .EQ. Y2) RETURN 462C Else move to the next point 463 IF ( E .GT. 0) THEN 464 X = X + D2X 465 Y = Y + D2Y 466 E = E + DB - DA 467 ELSE 468 X = X + D1X 469 Y = Y + D1Y 470 E = E + DB 471 ENDIF 472 GOTO 800 473C ENDDO 474 END 475 476 477C ------------------------------------------------------------ 478 SUBROUTINE LN03_DUMP(UNIT,XLEFT,XRIGHT,YTOP,YBOT, 479 1 POINTS,ACTIVE,NSIXROWS,NSIXCOLS) 480C------------------------------------------------------------- 481C Dump the bitmap to the printer 482C Only write active sixel rows, and do run length encoding, too 483C 484C 485C Parameters: 486C XLEFT: starting column in map, and initial x position 487C XRIGHT: last active column in map 488C YTOP: starting row in map, and initial y position 489C YBOT: last active row in the map 490 491 INTEGER XLEFT, XRIGHT, YTOP, YBOT, NSIXROWS, NSIXCOLS, UNIT 492 LOGICAL ACTIVE(0:*) 493 INTEGER*2 POINTS(0:*) 494 495 INTEGER*2 SXL 496 INTEGER IROW, JCOL, K, PTR, RPT, INDX, N, MAXLEN 497 CHARACTER*10 RUN, LN03_PACK 498 CHARACTER*256 BUFFER 499 CHARACTER*1 PAT, ESC 500 DATA ESC /27/ 501 DATA MAXLEN /75/ 502 LOGICAL DEBUG 503 DATA DEBUG /.false./ 504 INTEGER IOFFSET 505 PARAMETER(IOFFSET = 34) 506 507 CHARACTER*10 NEWX,NEWY 508 INTEGER N1,N2 509 510 NEWX = LN03_PACK(XLEFT,N1) 511 NEWY = LN03_PACK(YTOP+IOFFSET,N2) 512C Start at the top of the paper, down one line plus offset 513C The pixels start 70 decipoints above the first line 514C Set up the sixel modes 515 WRITE(UNIT, '(A)') ESC//'[7 I'//ESC//'[11h' 516 WRITE (UNIT, '(A)') 517 1 ESC//'['//NEWX(N1:)//'`'//ESC//'['//NEWY(N2:)//'d' 518 1//ESC//'P0;0;1q"100;100' 519C Now scan the bitmap 520 PTR = 1 521 DO 1000 IROW = 0, NSIXROWS-2 522 IF (ACTIVE(IROW)) THEN 523 if(debug)write(0,'(a,4(i6))')'row = ',irow 524 JCOL = XLEFT 525 DO WHILE (JCOL .LT. XRIGHT) 526 INDX = IROW*NSIXCOLS 527 SXL = POINTS(INDX + JCOL) 528 PAT = CHAR(IIAND(SXL,63) + 63) 529 RPT = 0 530C Look for repeated values on the rest of the line 531 K = JCOL + 1 532 DO WHILE( K .LT. XRIGHT .AND. 533 1 SXL .EQ. POINTS(INDX + K)) 534 RPT = RPT +1 535 K = K + 1 536 ENDDO 537C IF (DEBUG) WRITE(1, '(2I10,2I6,1X,A,I5,I5)') 538C 1 indx,indx+jcol, IROW, JCOL, PAT,ICHAR(PAT),SXL 539C Now check if there were any repeats 540 IF (RPT .GT. 0) THEN 541 RUN = LN03_PACK(RPT +1, N) 542 BUFFER(PTR:) = '!'//RUN(N:)//PAT 543 PTR = PTR + LEN(RUN(N:)) + 2 544 JCOL = JCOL + RPT + 1 545 ELSE 546 BUFFER(PTR:PTR) = PAT 547 PTR = PTR + 1 548 JCOL = JCOL + 1 549 ENDIF 550 IF (PTR .GE. MAXLEN) THEN 551 WRITE (UNIT, '(A)') BUFFER(:PTR-1) 552 PTR = 1 553 ENDIF 554 ENDDO 555 ENDIF 556C Terminate each scan with a graphic newline character 557 BUFFER(PTR:PTR) = '-' 558 IF (PTR .GE. MAXLEN) THEN 559 WRITE (UNIT, '(A)') BUFFER(:PTR) 560 PTR = 1 561 ELSE 562 PTR = PTR + 1 563 ENDIF 5641000 CONTINUE 565 IF(PTR .GT. 1) WRITE (UNIT, '(A)') BUFFER(:PTR-1) 566 WRITE(UNIT, '(A)') ESC//CHAR(92) 567 RETURN 568 END 569