1 SUBROUTINE IMDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) 2 INTEGER IFUNC, NBUF, LCHR 3 REAL RBUF(*) 4 CHARACTER*(*) CHR 5C----------------------------------------------------------------------- 6C PGPLOT driver for Impress (Imagen) device. 7C----------------------------------------------------------------------- 8C Version 0.9 - 1987 Aug 19 - T. J. Pearson. 9C Modifications: 10C REW -- 23 MAY 1988 -- Orientation from x axis, not h axis 11C REW -- 25 MAY 1988 -- Change physical min/max 12C from 3074/2324 to 3150/2400 10.5 x 8) 13C REW -- 31 MAY 1988 -- Include x and y offsets to improve centering 14C 15C Note: this is a preliminary release. The driver has the following 16C problems: (a) does not use hardware thick lines; (b) white lines do 17C not to erase background as they should; (c) lines are handled as 18C separate segments, instead of combining connected segments into paths, 19C which should be more efficient. 20C----------------------------------------------------------------------- 21C 22C Supported device: any Imagen printer that accepts the Impress page 23C description language. 24C 25C Device type code: /IMPRESS (landscape mode). 26C 27C Default file name: PGPLOT.IMPLOT. 28C 29C Default view surface dimensions: 30C 10.5 inches horizontal x 8 inches vertical (landscape mode). 31C Note that the Imagen laser printer prints from the bottom edge 32C of the sheet and cannot print on the top half inch of the sheet. 33C 34C Resolution: the driver uses coordinate increments of 1/300 inch. 35C The true resolution is device-dependent. 36C 37C Color capability: color indices 0 (erase), and 1 (black) 38C are supported. Requests for other color indices are 39C converted to 1. It is not possible to change color representation. 40C 41C Input capability: none. 42C 43C File format: binary, variable length records (max 1024 bytes); no 44C carriage control. 45C 46C Obtaining hardcopy: $ IMPRINT/IMPRESS file.type 47C----------------------------------------------------------------------- 48 CHARACTER*(*) TYPE, DEFNAM 49 PARAMETER (DEFNAM='PGPLOT.IMPLOT') 50 PARAMETER (TYPE='IMPRESS') 51 INTEGER BUFSIZ 52 PARAMETER (BUFSIZ=1024) 53 INTEGER BUFFER 54 INTEGER BUFLEV 55 INTEGER UNIT, IER 56 INTEGER*2 I0, I1, J0, J1, NPTS 57 INTEGER GRGMEM, GRFMEM 58 CHARACTER*10 MSG 59 INTEGER IC 60 BYTE BUF(100), COLOR 61 INTEGER NW 62 INTEGER SIZEX, SIZEY ! REW -- 26MAY88 63 PARAMETER (SIZEX=3150 ,SIZEY=2400) ! REW -- 26MAY88 64 INTEGER OFFSETX, OFFSETY ! REW -- 31MAY88 65 PARAMETER (OFFSETX=75, OFFSETY=15) ! REW -- 31MAY88 66C----------------------------------------------------------------------- 67C 68 GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, 69 1 110,120,130,140,150,160,170,180,190,200, 70 2 210,220,230), IFUNC 71 900 WRITE (MSG,'(I10)') IFUNC 72 CALL GRWARN('Unimplemented function in IMPRESS device driver:' 73 1 //MSG) 74 NBUF = -1 75 RETURN 76C 77C--- IFUNC = 1, Return device name ------------------------------------- 78C 79 10 CHR = TYPE 80 LCHR = LEN(TYPE) 81 RETURN 82C 83C--- IFUNC = 2, Return physical min and max for plot device, and range 84C of color indices --------------------------------------- 85C 86 20 RBUF(1) = 0 87 RBUF(2) = SIZEX ! rew -- 25 may 1988 88 RBUF(3) = 0 89 RBUF(4) = SIZEY ! rew -- 25 may 1988 90 RBUF(5) = 0 91 RBUF(6) = 1 92 NBUF = 6 93 RETURN 94C 95C--- IFUNC = 3, Return device resolution ------------------------------- 96C (Nominal values) 97C 98 30 RBUF(1) = 300.0 99 RBUF(2) = 300.0 100C (multiple strokes are spaced by 1 pixels, or 1/300 inch) 101 RBUF(3) = 1 102 NBUF = 3 103 RETURN 104C 105C--- IFUNC = 4, Return misc device info -------------------------------- 106C (Hardcopy, No cursor, No dashed lines, Area fill, 107C no thick lines) 108C 109 40 CHR = 'HNNANNNNNN' 110 LCHR = 10 111 RETURN 112C 113C--- IFUNC = 5, Return default file name ------------------------------- 114C 115 50 CHR = DEFNAM 116 LCHR = LEN(DEFNAM) 117 RETURN 118C 119C--- IFUNC = 6, Return default physical size of plot ------------------- 120C 121 60 RBUF(1) = 0 122 RBUF(2) = SIZEX ! rew -- 25 May 1988 123 RBUF(3) = 0 124 RBUF(4) = SIZEY ! rew -- 25 May 1988 125 NBUF = 4 126 RETURN 127C 128C--- IFUNC = 7, Return misc defaults ----------------------------------- 129C 130 70 RBUF(1) = 8.0 131 NBUF=1 132 RETURN 133C 134C--- IFUNC = 8, Select plot -------------------------------------------- 135C 136 80 CONTINUE 137 RETURN 138C 139C--- IFUNC = 9, Open workstation --------------------------------------- 140C 141 90 CONTINUE 142C -- allocate buffer 143 IER = GRGMEM(BUFSIZ, BUFFER) 144 IF (IER.NE.1) THEN 145 CALL GRGMSG(IER) 146 CALL GRWARN('Failed to allocate plot buffer.') 147 RBUF(2) = IER 148 RETURN 149 END IF 150C -- open device 151 CALL GRGLUN(UNIT) 152 NBUF = 2 153 RBUF(1) = UNIT 154 OPEN (UNIT=UNIT, FILE=CHR(:LCHR), CARRIAGECONTROL='NONE', 155 1 DEFAULTFILE=DEFNAM, DISPOSE='DELETE', STATUS='NEW', 156 2 FORM='UNFORMATTED', RECORDTYPE='VARIABLE', IOSTAT=IER, 157 3 RECL=256) 158 IF (IER.NE.0) THEN 159 CALL GRWARN('Cannot open output file for '//TYPE//' plot: '// 160 1 CHR(:LCHR)) 161 RBUF(2) = 0 162 CALL GRFLUN(UNIT) 163 IER = GRFMEM(BUFSIZ, BUFFER) 164 RETURN 165 ELSE 166 INQUIRE (UNIT=UNIT, NAME=CHR) 167 LCHR = LEN(CHR) 168 91 IF (CHR(LCHR:LCHR).EQ.' ') THEN 169 LCHR = LCHR-1 170 GOTO 91 171 END IF 172 RBUF(2) = 1 173 END IF 174 IC = 1 175C -- initialization 176 NPTS = 0 177 COLOR = 15 178 RETURN 179C 180C--- IFUNC=10, Close workstation --------------------------------------- 181C 182 100 CONTINUE 183 CLOSE (UNIT, DISPOSE='KEEP') 184 CALL GRFLUN(UNIT) 185 IER = GRFMEM(BUFSIZ, BUFFER) 186 IF (IER.NE.1) THEN 187 CALL GRWARN('Error deallocating plot buffer.') 188 CALL GRGMSG(IER) 189 END IF 190 RETURN 191C 192C--- IFUNC=11, Begin picture ------------------------------------------- 193C 194 110 CONTINUE 195C -- set coordinate system 196 BUF(1) = 205 ! SET_HV_SYSTEM 197 BUF(2) = 29 ! 0 0 3 5 ! REW -- 23 MAY 1988 198 BUF(3) = 135 ! SET_ABS_H 199 BUF(4) = 0 200 BUF(5) = 0 201 BUF(6) = 137 ! SET_ABS_V 202 BUF(7) = 0 203 BUF(8) = 0 204 NW = 8 205 GOTO 1000 206C 207C--- IFUNC=12, Draw line ----------------------------------------------- 208C 209 120 CONTINUE 210 IF (IC.EQ.0) RETURN 211 I0 = OFFSETX + NINT(RBUF(1)) 212 J0 = OFFSETY + NINT(RBUF(2)) 213 I1 = OFFSETX + NINT(RBUF(3)) 214 J1 = OFFSETY + NINT(RBUF(4)) 215 125 CONTINUE 216 BUF(1) = 230 ! CREATE_PATH 217 CALL GRIM00(BUF(2), 2) ! 2 vertices 218 CALL GRIM00(BUF(4), I0) ! coordinates of vertices 219 CALL GRIM00(BUF(6), J0) 220 CALL GRIM00(BUF(8), I1) 221 CALL GRIM00(BUF(10), J1) 222 BUF(12) = 234 ! DRAW_PATH 223 BUF(13) = COLOR ! black or white 224 NW = 13 225 GOTO 1000 226C 227C--- IFUNC=13, Draw dot ------------------------------------------------ 228C 229 130 CONTINUE 230 IF (IC.EQ.0) RETURN 231 I0 = OFFSETX + NINT(RBUF(1)) 232 J0 = OFFSETY + NINT(RBUF(2)) 233 I1 = I0 234 J1 = J0 235 GOTO 125 236C 237C--- IFUNC=14, End picture --------------------------------------------- 238C 239 140 CONTINUE 240 BUF(1) = 219 ! ENDPAGE 241 NW = 1 242 GOTO 1000 243C 244C--- IFUNC=15, Select color index -------------------------------------- 245C 246 150 CONTINUE 247 IC = RBUF(1) 248 IF (IC.LT.0 .OR. IC.GT.1) THEN 249 IC = 1 250 RBUF(1) = IC 251 END IF 252 COLOR = 15 253 IF (IC.EQ.0) COLOR = 0 254 RETURN 255C 256C--- IFUNC=16, Flush buffer. ------------------------------------------- 257C 258 160 CONTINUE 259 CALL GRIM03(%val(BUFFER), UNIT, BUFLEV) 260 RETURN 261C 262C--- IFUNC=17, Read cursor. -------------------------------------------- 263C Not implemented. 264C 265 170 CONTINUE 266 GOTO 900 267C 268C--- IFUNC=18, Erase alpha screen. ------------------------------------- 269C (Not implemented: no alpha screen) 270C 271 180 CONTINUE 272 RETURN 273C 274C--- IFUNC=19, Set line style. ----------------------------------------- 275C (Not implemented: should not be called) 276C 277 190 CONTINUE 278 GOTO 900 279C 280C--- IFUNC=20, Polygon fill. ------------------------------------------- 281C 282 200 CONTINUE 283 IF (NPTS.EQ.0) THEN 284 NPTS = RBUF(1) 285 BUF(1) = 230 ! CREATE_PATH 286 CALL GRIM00(BUF(2), NPTS) ! # vertices 287 NW = 3 288 ELSE 289 NPTS = NPTS-1 290 I0 = OFFSETX + NINT(RBUF(1)) 291 J0 = OFFSETY + NINT(RBUF(2)) 292 CALL GRIM00(BUF(1), I0) ! coordinates of vertex 293 CALL GRIM00(BUF(3), J0) 294 NW = 4 295 IF (NPTS.EQ.0) THEN 296 BUF(5) = 233 ! FILL_PATH 297 BUF(6) = COLOR ! black or white 298 NW = 6 299 END IF 300 END IF 301 GOTO 1000 302C 303C--- IFUNC=21, Set color representation. ------------------------------- 304C (Not implemented: ignored) 305C 306 210 CONTINUE 307 RETURN 308C 309C--- IFUNC=22, Set line width. ----------------------------------------- 310C (Not implemented: should not be called) 311C 312 220 CONTINUE 313 GOTO 900 314C 315C--- IFUNC=23, Escape -------------------------------------------------- 316C (Not implemented: ignored) 317C 318 230 CONTINUE 319 RETURN 320C 321C--- Send the command. ------------------------------------------------- 322C 323 1000 CALL GRIM02(BUF,NW,%val(BUFFER),BUFLEV,UNIT) 324C----------------------------------------------------------------------- 325 END 326 327C*GRIM00 -- PGPLOT Impress driver, write word 328C+ 329 SUBROUTINE GRIM00(BUF,WORD) 330 BYTE BUF(2), WORD(2) 331C-- 332 BUF(1) = WORD(2) 333 BUF(2) = WORD(1) 334 END 335 336C*GRIM02 -- PGPLOT Impress driver, transfer data to buffer 337C+ 338 SUBROUTINE GRIM02 (INSTR, N, BUFFER, HWM, UNIT) 339 INTEGER N, HWM, UNIT 340 BYTE INSTR(*), BUFFER(*) 341C 342C Arguments: 343C INSTR (input) : text of instruction (bytes). 344C N (input) : number of bytes to transfer. 345C BUFFER (input) : output buffer. 346C HWM (in/out) : number of bytes used in BUFFER. 347C UNIT (input) : channel number for output (when buffer is full). 348C 349C Subroutines called: 350C GRIM03 351C----------------------------------------------------------------------- 352 INTEGER BUFSIZ 353 PARAMETER (BUFSIZ=1024) 354 INTEGER I 355C----------------------------------------------------------------------- 356 IF (HWM+N.GE.BUFSIZ) CALL GRIM03(BUFFER, UNIT, HWM) 357 DO 10 I=1,N 358 HWM = HWM + 1 359 BUFFER(HWM) = INSTR(I) 360 10 CONTINUE 361C----------------------------------------------------------------------- 362 END 363 364C*GRIM03 -- PGPLOT Impress driver, copy buffer to file 365C+ 366 SUBROUTINE GRIM03 (BUFFER, UNIT, N) 367 BYTE BUFFER(*) 368 INTEGER UNIT, N 369C 370C Arguments: 371C BUFFER (input) address of buffer to be output 372C UNIT (input) unit number for output 373C N (input) number of bytes to transfer 374C (output) set to zero 375C----------------------------------------------------------------------- 376 INTEGER J 377C----------------------------------------------------------------------- 378 IF (N.GT.0) WRITE (UNIT) (BUFFER(J),J=1,N) 379 N = 0 380C----------------------------------------------------------------------- 381 END 382