1C*GCDRIV -- PGPLOT Genicom printer driver 2C+ 3 SUBROUTINE GCDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) 4 INTEGER IFUNC, NBUF, LCHR 5 REAL RBUF(*) 6 CHARACTER*(*) CHR 7C 8C PGPLOT driver for Genicom printer device. 9C 10C This driver is a copy of pxdriver.for with minor changes to put 11C the genicom printer in the proper mode and scale correctly. 12C Version 1.0 - 1990 Feb 12 - J. H. Trice. 13C======================================================================= 14C 15C Supported device: Genicom 4410 dot-matrix printer. 16C 17C Device type code: /GENICOM. 18C 19C Default device name: PGPLOT.PRPLOT. 20C 21C Default view surface dimensions: 10.25in (horizontal) by 7.8in 22C (vertical). 23C 24C Resolution: 144 (x) x 140 (y) pixels/inch. 25C 26C Color capability: Color indices 0 (erase, white) and 1 (black) are 27C supported. It is not possible to change color representation. 28C 29C Input capability: None. 30C 31C File format: Variable-length records, maximum 197 bytes, with 32C embedded carriage-control characters. A full-page plot occupies 33C 600 512-byte blocks. 34C 35C Obtaining hardcopy: Use the command PRINT/PASSALL. 36C----------------------------------------------------------------------- 37 CHARACTER*(*) TYPE, DEFNAM 38 PARAMETER (TYPE= 39 : 'GENICOM (Genicom 4410 dot-matrix printer, landscape)') 40 PARAMETER (DEFNAM='PGPLOT.PRPLOT') 41 BYTE FF 42 PARAMETER (FF=12) 43C 44 INTEGER UNIT, IER, IC, BX, BY, NPICT 45 INTEGER GRGMEM, GRFMEM 46 CHARACTER*10 MSG 47 INTEGER BITMAP 48C----------------------------------------------------------------------- 49C 50 GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, 51 1 110,120,130,140,150,160,170,180,190,200, 52 2 210,220,230), IFUNC 53 900 WRITE (MSG,'(I10)') IFUNC 54 CALL GRWARN('Unimplemented function in '//TYPE//' device driver:' 55 1 //MSG) 56 NBUF = -1 57 RETURN 58C 59C--- IFUNC = 1, Return device name ------------------------------------- 60C 61 10 CHR = TYPE 62 LCHR = LEN(TYPE) 63 RETURN 64C 65C--- IFUNC = 2, Return physical min and max for plot device, and range 66C of color indices --------------------------------------- 67C 68 20 RBUF(1) = 0 69 RBUF(2) = 1510 70 RBUF(3) = 0 71 RBUF(4) = 1154 72 RBUF(5) = 0 73 RBUF(6) = 1 74 NBUF = 6 75 RETURN 76C 77C--- IFUNC = 3, Return device resolution ------------------------------- 78C 79 30 RBUF(1) = 144.0 80 RBUF(2) = 140.0 81 RBUF(3) = 1 82 NBUF = 3 83 RETURN 84C 85C--- IFUNC = 4, Return misc device info -------------------------------- 86C (This device is Hardcopy, No cursor, No dashed lines, No area fill, 87C no thick lines) 88C 89 40 CHR = 'HNNNNNNNNN' 90 LCHR = 10 91 RETURN 92C 93C--- IFUNC = 5, Return default file name ------------------------------- 94C 95 50 CHR = DEFNAM 96 LCHR = LEN(DEFNAM) 97 RETURN 98C 99C--- IFUNC = 6, Return default physical size of plot ------------------- 100C 101 60 RBUF(1) = 0 102 RBUF(2) = 1510 103 RBUF(3) = 0 104 RBUF(4) = 1154 105 NBUF = 4 106 RETURN 107C 108C--- IFUNC = 7, Return misc defaults ----------------------------------- 109C 110 70 RBUF(1) = 1 111 NBUF=1 112 RETURN 113C 114C--- IFUNC = 8, Select plot -------------------------------------------- 115C 116 80 CONTINUE 117 RETURN 118C 119C--- IFUNC = 9, Open workstation --------------------------------------- 120C 121 90 CONTINUE 122C -- dimensions of plot buffer 123 BY = 194 ! 1164/6 124 BX = 1520 125 CALL GRGLUN(UNIT) 126 RBUF(1) = UNIT 127 NPICT = 0 128 OPEN (UNIT=UNIT, FILE=CHR(:LCHR), CARRIAGECONTROL='NONE', 129 1 DEFAULTFILE=DEFNAM, DISPOSE='DELETE', STATUS='NEW', 130 2 RECL=197, 131 3 FORM='UNFORMATTED', RECORDTYPE='VARIABLE', IOSTAT=IER) 132 IF (IER.NE.0) THEN 133 CALL GRWARN('Cannot open output file for '//TYPE//' plot: '// 134 1 CHR(:LCHR)) 135 RBUF(2) = 0 136 CALL GRFLUN(UNIT) 137 ELSE 138 INQUIRE (UNIT=UNIT, NAME=CHR) 139 LCHR = LEN(CHR) 140 91 IF (CHR(LCHR:LCHR).EQ.' ') THEN 141 LCHR = LCHR-1 142 GOTO 91 143 END IF 144 RBUF(2) = 1 145 END IF 146 IER = GRGMEM(BX*BY, BITMAP) 147 IF (IER.NE.1) THEN 148 CALL GRGMSG(IER) 149 CALL GRWARN('Failed to allocate plot buffer.') 150 RBUF(2) = IER 151 CLOSE (UNIT=UNIT, DISPOSE='DELETE') 152 CALL GRFLUN(UNIT) 153 END IF 154 RETURN 155C 156C--- IFUNC=10, Close workstation --------------------------------------- 157C 158 100 CONTINUE 159 CLOSE (UNIT=UNIT, DISPOSE='KEEP') 160 CALL GRFLUN(UNIT) 161 IER = GRFMEM(BX*BY, BITMAP) 162 IF (IER.NE.1) THEN 163 CALL GRGMSG(IER) 164 CALL GRWARN('Failed to deallocate plot buffer.') 165 END IF 166 RETURN 167C 168C--- IFUNC=11, Begin picture ------------------------------------------- 169C 170 110 CONTINUE 171 NPICT = NPICT+1 172C% type *,'Begin picture',NPICT 173 IF (NPICT.GT.1) WRITE (UNIT=UNIT) FF 174 CALL GRGC03(BX*BY, %val(BITMAP), 'C0'X) 175 RETURN 176C 177C--- IFUNC=12, Draw line ----------------------------------------------- 178C 179 120 CONTINUE 180 CALL GRGC01(1, RBUF, IC, BX, BY, %val(BITMAP)) 181 RETURN 182C 183C--- IFUNC=13, Draw dot ------------------------------------------------ 184C 185 130 CONTINUE 186 CALL GRGC01(0, RBUF, IC, BX, BY, %val(BITMAP)) 187 RETURN 188C 189C--- IFUNC=14, End picture --------------------------------------------- 190C 191 140 CONTINUE 192C% type *,'End picture ',NPICT 193 CALL GRGC02(UNIT, BX, BY, %val(BITMAP)) 194 RETURN 195C 196C--- IFUNC=15, Select color index -------------------------------------- 197C 198 150 CONTINUE 199 IC = RBUF(1) 200 IF (IC.LT.0 .OR. IC.GT.1) THEN 201 IC = 1 202 RBUF(1) = IC 203 END IF 204 RETURN 205C 206C--- IFUNC=16, Flush buffer. ------------------------------------------- 207C (Not used.) 208C 209 160 CONTINUE 210 RETURN 211C 212C--- IFUNC=17, Read cursor. -------------------------------------------- 213C (Not implemented: should not be called) 214C 215 170 CONTINUE 216 GOTO 900 217C 218C--- IFUNC=18, Erase alpha screen. ------------------------------------- 219C (Not implemented: no alpha screen) 220C 221 180 CONTINUE 222 RETURN 223C 224C--- IFUNC=19, Set line style. ----------------------------------------- 225C (Not implemented: should not be called) 226C 227 190 CONTINUE 228 GOTO 900 229C 230C--- IFUNC=20, Polygon fill. ------------------------------------------- 231C (Not implemented: should not be called) 232C 233 200 CONTINUE 234 GOTO 900 235C 236C--- IFUNC=21, Set color representation. ------------------------------- 237C (Not implemented: ignored) 238C 239 210 CONTINUE 240 RETURN 241C 242C--- IFUNC=22, Set line width. ----------------------------------------- 243C (Not implemented: should not be called) 244C 245 220 CONTINUE 246 GOTO 900 247C 248C--- IFUNC=23, Escape -------------------------------------------------- 249C (Not implemented: ignored) 250C 251 230 CONTINUE 252 RETURN 253C----------------------------------------------------------------------- 254 END 255 256C*GRGC01 -- PGPLOT Genicom printer driver, draw line 257C+ 258 SUBROUTINE GRGC01 (LINE,RBUF,ICOL, BX, BY, BITMAP) 259 INTEGER LINE 260 REAL RBUF(4) 261 INTEGER ICOL, BX, BY 262 BYTE BITMAP(BY,BX) 263C 264C Draw a straight-line segment from absolute pixel coordinates 265C (RBUF(1),RBUF(2)) to (RBUF(3),RBUF(4)). The line either overwrites 266C (sets to black) or erases (sets to white) the previous contents 267C of the bitmap, depending on the current color index. Setting bits 268C is accomplished with a VMS BISB2 instruction, expressed in 269C Fortran as .OR.; clearing bits is accomplished with a VMS BICB2 270C instruction, expressed in Fortran as .AND..NOT.. The line is 271C generated with a Simple Digital Differential Analyser (ref: 272C Newman & Sproull). 273C 274C Arguments: 275C 276C LINE I I =0 for dot, =1 for line. 277C RBUF(1),RBUF(2) I R Starting point of line. 278C RBUF(3),RBUF(4) I R End point of line. 279C ICOL I I =0 for erase, =1 for write. 280C BITMAP I/O B (address of) the frame buffer. 281C 282C----------------------------------------------------------------------- 283 BYTE QMASK(0:5) 284 INTEGER LENGTH, KX, KY, K 285 REAL D, XINC, YINC, XP, YP 286 DATA QMASK /'01'x,'02'x,'04'x,'08'x,'10'x,'20'x/ 287C 288 IF (LINE.GT.0) THEN 289 D = MAX(ABS(RBUF(3)-RBUF(1)), ABS(RBUF(4)-RBUF(2))) 290 LENGTH = D 291 IF (LENGTH.EQ.0) THEN 292 XINC = 0. 293 YINC = 0. 294 ELSE 295 XINC = (RBUF(3)-RBUF(1))/D 296 YINC = (RBUF(4)-RBUF(2))/D 297 END IF 298 ELSE 299 LENGTH = 0 300 XINC = 0. 301 YINC = 0. 302 END IF 303 XP = RBUF(1)+0.5 304 YP = RBUF(2)+0.5 305 IF (ICOL.NE.0) THEN 306 DO K=0,LENGTH 307 KY = BX - XP -5 308 KX = (BY*6-1)-INT(YP) 309 BITMAP(KX/6+1,KY+1) = BITMAP(KX/6+1,KY+1) .OR. 310 1 QMASK(MOD(KX,6)) 311 XP = XP + XINC 312 YP = YP + YINC 313 END DO 314 ELSE 315 DO K=0,LENGTH 316 KY = BX - XP -5 317 KX = (BY*6-1)-INT(YP) 318 BITMAP(KX/6+1,KY+1) = BITMAP(KX/6+1,KY+1) .AND. 319 1 (.NOT.QMASK(MOD(KX,6))) 320 XP = XP + XINC 321 YP = YP + YINC 322 END DO 323 END IF 324 END 325 326C*GRGC02 -- PGPLOT Genicom driver, copy bitmap to output file 327C+ 328 SUBROUTINE GRGC02 (UNIT, BX, BY, BITMAP) 329 INTEGER UNIT, BX, BY 330 BYTE BITMAP(BY,BX) 331C 332C Arguments: 333C UNIT (input) Fortran unit number for output 334C BX, BY (input) dimensions of BITMAP 335C BITMAP (input) the bitmap array 336C----------------------------------------------------------------------- 337 BYTE SUFFIX(3),PREGEN(10),POSTGEN(2) 338 DATA SUFFIX/ 5, 13, 10/ 339 DATA PREGEN/27, 91,52,59,54,59,53,113,27,80/ 340 DATA POSTGEN/27, 92/ 341 INTEGER I, J, K 342C 343C WRITE PREFIX TO PUT IN HIGH DENSITY GRAPHICS MODE 344C 345 WRITE(UNIT=UNIT) PREGEN 346C 347C Write bitmap. 348C 349 DO J=1,BX 350 DO K=BY,2,-1 351 IF (BITMAP(K,J).NE.'C0'X) GOTO 10 352 END DO 353 10 WRITE (UNIT=UNIT) (BITMAP(I,J),I=1,K),SUFFIX 354 END DO 355 WRITE(UNIT=UNIT) POSTGEN 356C 357C Write blank plot lines to fill up page 358C 359 END 360 361C*GRGC03 -- fill buffer with a specified character 362C+ 363 SUBROUTINE GRGC03 (BUFSIZ,BUFFER,FILL) 364C 365C GRPCKG (internal routine): fill a buffer with a given character. 366C 367C Arguments: 368C 369C BUFFER (byte array, input): (address of) the buffer. 370C BUFSIZ (integer, input): number of bytes in BUFFER. 371C FILL (integer, input): the fill character. BUFSIZ bytes starting at 372C address BUFFER are set to contents of FILL. 373C-- 374C (1-Feb-1983) 375C----------------------------------------------------------------------- 376 INTEGER BUFSIZ, I 377 BYTE FILL 378 BYTE BUFFER(BUFSIZ) 379C 380 DO 10 I=1,BUFSIZ 381 BUFFER(I) = FILL 382 10 CONTINUE 383 END 384