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