1C*GRQM00 -- PGPLOT QMS/QUIC driver 2 3 SUBROUTINE QMDRIV (IFUNC, RBUF, NBUF, CHR, LCHR, MODE) 4 INTEGER IFUNC, NBUF, LCHR, MODE 5 REAL RBUF(*) 6 CHARACTER*(*) CHR 7C----------------------------------------------------------------------- 8C PGPLOT driver for QUIC devices (QMS and Talaris 800/1200/1500/2400) 9C----------------------------------------------------------------------- 10C Version 0.1 - 1987 Oct 22 - Patrick P. Murphy, NRAO/VLA [PPM] 11C Version 0.2 - 1987 Oct 28 - [PPM] Fix backwards and scale bugs 12C Version 1.0 - 1987 Nov 03 - [PPM] Don't form feed if nothing drawn. 13C Version 1.1 - 1987 Nov 03 - [PPM] No formfeed at very end of file 14C Version 2.0 - 1987 Nov 18 - [PPM] Get scaling done right. 15C Version 2.1 - 1991 Jun 28 - [TJP] Standardization. 16C Version 2.2 - 1991 Nov 6 - [TJP] Standardization. 17C Version 3.0 - 1994 Feb 25 - [TJP] Combine portrait and landscape 18C modes in one file. 19C----------------------------------------------------------------------- 20C 21C Supported device: Any QMS or Talaris printer that accepts the QUIC 22C page description language. 4-bit mode is used. 23C 24C Device type code: /QMS (landscape mode 1) 25C /VQMS (portrait mode 2) 26C 27C Default file name: PGPLOT.QMPLOT. 28C 29C Default view surface dimensions: 30C 10.25 inches horizontal x 7.75 inches vertical (landscape mode), 31C 7.75 inches horizontal x 10.25 inches vertical (portrait mode), 32C margins of 0.5 inches on top and left of page. 33C 34C Resolution: The driver uses coordinate increments of 1/1000 inch. 35C The true resolution is device-dependent; at time of 36C writing, it is typically 300 dots per inch. 37C 38C Color capability: Color indices 0 (erase), and 1 (black) are 39C supported. Requests for other color indices are 40C converted to 1. It is not possible to change color 41C representation. 42C 43C Input capability: None. 44C 45C File format: Ascii, variable length records (max 130 bytes); carriage 46C return ("LIST") carriage control. This length can be 47C easily changed if needed. 48C 49C Obtaining hardcopy: send the file to an appropriate printer. 50C----------------------------------------------------------------------- 51C 52 CHARACTER*(*) DEVTPL, DEVTPP, DEFNAM 53 PARAMETER (DEFNAM='PGPLOT.QMPLOT') 54 PARAMETER (DEVTPL='QMS (QUIC/QMS file, landscape orientation)') 55 PARAMETER (DEVTPP='VQMS (QUIC/QMS file, portrait orientation)') 56C 57 CHARACTER*130 BUFFER 58 CHARACTER*16 HEXSTR 59 CHARACTER*10 MSG 60 CHARACTER*40 TEMP 61 INTEGER UNIT, IER, BUFLEN, MAXLEN, I0, J0, I1, J1, NPTS, IC, 62 : ISTYLE, LINWID, GROPTX 63 REAL QXSIZE, QYSIZE, QXSCAL, QYSCAL 64 LOGICAL NOTHIN, ENDFIL 65C 66C ---- Change MAXLEN if you want a shorter or longer max output line 67C ---- length. Also change the declared length of BUFFER too! The 68C ---- Q*SIZE parameters are the physical size of the plot (used more 69C ---- than once here) in resolution units (1/1000 inch). The Q*SCAL 70C ---- parameters are PGPLOT-modifiable scale factors. 71C 72 PARAMETER (MAXLEN = 130, 73 : QXSIZE = 10250.0, 74 : QYSIZE = 7750.00) 75C 76 SAVE UNIT, IC, BUFFER, BUFLEN, NPTS, QXSCAL, QYSCAL, NOTHIN, 77 : ENDFIL 78C 79 DATA HEXSTR /'0123456789ABCDEF'/ 80C 81C======================================================================= 82C 83C ---- Do the best one can in F77 for a "case" statement. -------------- 84C 85 GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, 86 1 110,120,130,140,150,160,170,180,190,200, 87 2 210,220,230), IFUNC 88C 89C ---- Unknown opcode/function; most likely a logic error somewhere ---- 90C 91 900 WRITE (MSG,'(I10)') IFUNC 92 CALL GRWARN('Unimplemented function in QMS'// 93 : ' device driver:'//MSG) 94 NBUF = -1 95 RETURN 96C 97C--- IFUNC = 1, Return device name ------------------------------------- 98C 99 10 IF (MODE.EQ.1) THEN 100 CHR = DEVTPL 101 LCHR = LEN(DEVTPL) 102 ELSE IF (MODE.EQ.2) THEN 103 CHR = DEVTPP 104 LCHR = LEN(DEVTPP) 105 ELSE 106 CALL GRWARN('Internal error in QMDRIV') 107 END IF 108 RETURN 109C 110C--- IFUNC = 2, Return physical min and max for plot device, and range 111C of color indices --------------------------------------- 112C Units are in device co-ordinates (1/1000 inches) 113C 114 20 IF (MODE.EQ.1) THEN 115 RBUF(2) = QXSIZE 116 RBUF(4) = QYSIZE 117 ELSE 118 RBUF(2) = QYSIZE 119 RBUF(4) = QXSIZE 120 END IF 121 RBUF(1) = 0.0 122 RBUF(3) = 0.0 123 RBUF(5) = 0.0 124 RBUF(6) = 1.0 125 NBUF = 6 126 RETURN 127C 128C--- IFUNC = 3, Return device resolution ------------------------------- 129C (Nominal values) 130C 131 30 RBUF(1) = 1000.0 132 RBUF(2) = 1000.0 133C 134C (multiple strokes are spaced by 3.333 pixels, or 1/300 inch) 135C 136 RBUF(3) = 3.333 137 NBUF = 3 138 RETURN 139C 140C--- IFUNC = 4, Return misc device info -------------------------------- 141C (Hardcopy, No cursor, Dashed lines, Area fill, Thick lines) 142C 143 40 CHR = 'HNDATNNNNN' 144 LCHR = 10 145 RETURN 146C 147C--- IFUNC = 5, Return default file name ------------------------------- 148C 149 50 CHR = DEFNAM 150 LCHR = LEN(DEFNAM) 151 RETURN 152C 153C--- IFUNC = 6, Return default physical size of plot ------------------- 154C (in device coordinates). 155C 156 60 IF (MODE.EQ.1) THEN 157 RBUF(2) = QXSIZE 158 RBUF(4) = QYSIZE 159 ELSE 160 RBUF(2) = QYSIZE 161 RBUF(4) = QXSIZE 162 END IF 163 RBUF(1) = 0.0 164 RBUF(3) = 0.0 165 NBUF = 4 166 RETURN 167C 168C--- IFUNC = 7, Return misc defaults ----------------------------------- 169C Currently scale factor for "obsolete" character set of old GRPCKG 170C routines (not used by PGPLOT routines). Value copied from IMAGEN 171C driver -- I assume this is a good value (PPM 871026). 172C 173 70 RBUF(1) = 8.0 174 NBUF=1 175 RETURN 176C 177C--- IFUNC = 8, Select plot -------------------------------------------- 178C Future option, nothing done yet. (Multiple devices open at one 179C time will be allowed later; this opcode will select active device). 180C 181 80 CONTINUE 182 RETURN 183C 184C--- IFUNC = 9, Open workstation --------------------------------------- 185C 186 90 CONTINUE 187C 188C -- Get a Unit number. 189C 190 CALL GRGLUN(UNIT) 191C 192C -- Open the file. 193C 194 NBUF = 2 195 RBUF(1) = UNIT 196 IER = GROPTX(UNIT, CHR(1:LCHR), DEFNAM, 1) 197 IF (IER.NE.0) THEN 198 TEMP = CHR(1:LCHR) 199 CALL GRWARN('Cannot open output file for QMS'// 200 : ' plot: '//TEMP) 201 RBUF(2) = 0 202 CALL GRFLUN(UNIT) 203 RETURN 204 ELSE 205 INQUIRE (UNIT=UNIT, NAME=CHR) 206 LCHR = LEN(CHR) 207 91 IF (CHR(LCHR:LCHR).EQ.' ') THEN 208 LCHR = LCHR-1 209 GOTO 91 210 END IF 211 RBUF(2) = 1 212 END IF 213C 214C -- initialization 215C 216 IC = 1 217 BUFFER = ' ' 218 BUFLEN = 0 219 NPTS = 0 220 QXSCAL = 1.0 221 QYSCAL = 1.0 222 NOTHIN = .TRUE. 223C 224C -- Initialize QUIC, get into free format, out of other possible 225C -- modes (vector graphics, word processing), reset interpretation: 226C -- Set landscape/portrait mode, set margins, enter vector 227C graphics mode 228C 229 BUFLEN = 1 230 CALL GRQM00 (UNIT, BUFFER, BUFLEN) 231 BUFFER = '^PY^-' 232 BUFLEN = 5 233 CALL GRQM00 (UNIT, BUFFER, BUFLEN) 234 BUFFER(1:38) = '^F^IGE^G^IWE^G^IP0000^G^ISYNTAX00000^G' 235 IF (MODE.EQ.1) THEN 236 BUFFER(39:80) = '^IOL^G^IMH0050010750^G^IMV0050008250^G^IGV' 237 ELSE 238 BUFFER(39:80) = '^IOP^G^IMH0050008250^G^IMV0050010750^G^IGV' 239 END IF 240 BUFLEN = 80 241 CALL GRQM00 (UNIT, BUFFER, BUFLEN) 242 RETURN 243C 244C--- IFUNC=10, Close workstation --------------------------------------- 245C 246 100 CONTINUE 247 IF (NOTHIN) THEN 248C 249C -- Nothing was plotted so no need to keep the file around. 250C 251 CLOSE (UNIT) 252C 253 ELSE 254C 255C -- see if the last call was end picture; if so, remove formfeed 256C (this assumes the printer/queue combination will supply the 257C form feeds; if not, comment out this next line). 258C 259 IF (ENDFIL) BUFLEN = BUFLEN - 2 260C 261C -- Flush out anything left in the buffer 262C 263 IF (BUFLEN .GT. 0) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 264C 265C -- Don't need to formfeed; end picture will do that. 266C 267 BUFFER = '^IGE^G^O^-' 268 BUFLEN = 10 269 CALL GRQM00 (UNIT, BUFFER, BUFLEN) 270 BUFFER = '^PN^-' 271 BUFLEN = 5 272 CALL GRQM00 (UNIT, BUFFER, BUFLEN) 273 CLOSE (UNIT, STATUS='KEEP') 274 ENDIF 275C 276C -- Return UNIT to free pool. 277C 278 CALL GRFLUN(UNIT) 279 RETURN 280C 281C--- IFUNC=11, Begin picture and possibly rescale ----------------------- 282C 283 110 CONTINUE 284 ENDFIL = .FALSE. 285 IF (MODE.EQ.1) THEN 286 QXSCAL = MIN (1., RBUF(1) / QXSIZE) 287 QYSCAL = MIN (1., RBUF(2) / QYSIZE) 288 ELSE 289 QXSCAL = MIN (1., RBUF(2) / QXSIZE) 290 QYSCAL = MIN (1., RBUF(1) / QYSIZE) 291 END IF 292 RETURN 293C 294C--- IFUNC=12, Draw line ----------------------------------------------- 295C When I copied the Imagen driver, I got output backwards in the 296C X direction (mirrored). Hence I mirror it back now. 297C 298 120 CONTINUE 299 IF (NOTHIN) NOTHIN = .FALSE. 300 IF (IC.EQ.0) RETURN 301 IF (MODE.EQ.1) THEN 302 I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL) 303 J0 = NINT(RBUF(2) * QYSCAL) 304 I1 = NINT((QXSIZE - RBUF(3)) * QXSCAL) 305 J1 = NINT(RBUF(4) * QYSCAL) 306 ELSE 307 I0 = NINT(RBUF(1) * QYSCAL) 308 J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL) 309 I1 = NINT(RBUF(3) * QYSCAL) 310 J1 = NINT((QXSIZE - RBUF(4)) * QXSCAL) 311 END IF 312 125 CONTINUE 313 IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 314 BUFFER(BUFLEN+1:BUFLEN+2) = '^U' 315 WRITE (BUFFER(BUFLEN+3:BUFLEN+13), '(I5.5,1H:,I5.5)') I0, J0 316 BUFLEN = BUFLEN + 13 317 IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 318 BUFFER(BUFLEN+1:BUFLEN+2) = '^D' 319 WRITE (BUFFER(BUFLEN+3:BUFLEN+13), '(I5.5,1H:,I5.5)') I1, J1 320 BUFLEN = BUFLEN + 13 321 RETURN 322C 323C--- IFUNC=13, Draw dot ------------------------------------------------ 324C QUIC takes care of dot size by the ^PW (pen width) command so we 325C don't have to worry about it here. Just draw to same point and 326C let the "draw line" code handle it. 327C 328 130 CONTINUE 329 IF (NOTHIN) NOTHIN = .FALSE. 330 IF (IC.EQ.0) RETURN 331 IF (MODE.EQ.1) THEN 332 I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL) 333 J0 = NINT(RBUF(2) * QYSCAL) 334 ELSE 335 I0 = NINT(RBUF(1) * QYSCAL) 336 J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL) 337 END IF 338 I1 = I0 339 J1 = J0 340 GOTO 125 341C 342C--- IFUNC=14, End picture --------------------------------------------- 343C This means do a form feed. QUIC allows form feeds within vector 344C graphics mode so just put it in the stream. 345C Changed 871103 [PPM] so that no formfeed done if "NOTHIN" is true. 346C That means there is nothing on the paper. 347C Changed again (same date, person): set flag for end workstation 348C 349 140 CONTINUE 350 ENDFIL = .TRUE. 351 IF (.NOT. NOTHIN) THEN 352 IF (BUFLEN+2 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 353 BUFFER(BUFLEN+1:BUFLEN+2) = '^,' 354 BUFLEN = BUFLEN + 2 355 ENDIF 356 RETURN 357C 358C--- IFUNC=15, Select color index -------------------------------------- 359C 360 150 CONTINUE 361 IC = RBUF(1) 362 IF (IC.LT.0 .OR. IC.GT.1) THEN 363 IC = 1 364 RBUF(1) = IC 365 END IF 366 RETURN 367C 368C--- IFUNC=16, Flush buffer. ------------------------------------------- 369C Hardcopy so ignore it 370C 371 160 CONTINUE 372C CALL GRQM00 (UNIT, BUFFER, BUFLEN) Not needed! 373 RETURN 374C 375C--- IFUNC=17, Read cursor. -------------------------------------------- 376C Not implemented, hardcopy device. Return error code. 377C 378 170 CONTINUE 379 GOTO 900 380C 381C--- IFUNC=18, Erase alpha screen. ------------------------------------- 382C (Not implemented: no alpha screen so ignore it). 383C 384 180 CONTINUE 385 RETURN 386C 387C--- IFUNC=19, Set line style. ----------------------------------------- 388C 389 190 CONTINUE 390 ISTYLE = NINT(RBUF(1)) 391 IF (ISTYLE .LT. 1) ISTYLE = 1 392 IF (ISTYLE .GT. 5) ISTYLE = 5 393C 394C -- Convert PGPLOT line styles 1 thru 5 to QUIC equivalents 395C 396 GOTO (191,192,193,194,195) ISTYLE 397C 398C Select ISTYLE in CASE: 399C Full line 400 191 ISTYLE = 0 401 GOTO 196 402C Long dashes 403 192 ISTYLE = 1 404 GOTO 196 405C Dash-dot 406 193 ISTYLE = 7 407 GOTO 196 408C Dotted 409 194 ISTYLE = 2 410 GOTO 196 411C Dash-dot-dot-dot 412 195 ISTYLE = 9 413 GOTO 196 414C End SELECT/CASE on ISTYLE 415 196 CONTINUE 416C 417C -- I use HEXSTR here for system-independence and also in case the 418C -- PGPLOT package ever adds more line styles. 419C 420 IF (BUFLEN+3 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 421 BUFFER(BUFLEN+1:BUFLEN+2) = '^V' 422 ISTYLE = ISTYLE + 1 423 BUFFER(BUFLEN+3:BUFLEN+3) = HEXSTR(ISTYLE:ISTYLE) 424 BUFLEN = BUFLEN + 3 425 RETURN 426C 427C--- IFUNC=20, Polygon fill. ------------------------------------------- 428C 429 200 CONTINUE 430 IF (IC .EQ. 0) RETURN 431C 432C -- Use NPTS as our indicator of whether this is first time or not 433C 434 IF (NPTS.EQ.0) THEN 435C 436C -- First time so set number of points in polygon 437C 438 NPTS = RBUF(1) 439 IF (BUFLEN+8 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 440C 441C -- Use black fill, no border (in case PGPLOT doesn't go back to 442C the last point) -------------------------------------------- 443C 444 BUFFER (BUFLEN+1:BUFLEN+8) = '^PF020^U' 445 BUFLEN = BUFLEN + 8 446 ELSE 447C 448C -- Second or other time so bump NPTS and draw to next vertex 449C 450 IF (NOTHIN) NOTHIN = .FALSE. 451 NPTS = NPTS - 1 452 IF (MODE.EQ.1) THEN 453 I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL) 454 J0 = NINT(RBUF(2) * QYSCAL) 455 ELSE 456 I0 = NINT(RBUF(1) * QYSCAL) 457 J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL) 458 END IF 459 IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 460 WRITE (BUFFER(BUFLEN+1:BUFLEN+11), '(I5.5,1H:,I5.5)') I0, J0 461 BUFFER(BUFLEN+12:BUFLEN+13) = '^D' 462 BUFLEN = BUFLEN + 13 463 IF (NPTS .EQ. 0) THEN 464C 465C -- get rid of last ^D and give the Polygon fill command 466C 467 BUFLEN = BUFLEN - 2 468 BUFFER(BUFLEN+1:BUFLEN+2) = ' ' 469 IF (BUFLEN+3 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 470 BUFFER(BUFLEN+1:BUFLEN+3) = '^PS' 471 BUFLEN = BUFLEN + 3 472 END IF 473 END IF 474 RETURN 475C 476C--- IFUNC=21, Set color representation. ------------------------------- 477C (Not implemented: ignored. Will we ever get color laser printers?) 478C 479 210 CONTINUE 480 RETURN 481C 482C--- IFUNC=22, Set line width. ----------------------------------------- 483C 484 220 CONTINUE 485C 486C -- QUIC pen width is in dots (1/300 inch) so convert from 1/200's. 487C 488 LINWID = NINT(RBUF(1) * 1.5) 489 IF (LINWID .LT. 1) LINWID = 1 490 IF (LINWID .GT. 31) LINWID = 31 491 IF (BUFLEN+5 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 492 BUFFER(BUFLEN+1:BUFLEN+3) = '^PW' 493 WRITE (BUFFER(BUFLEN+4:BUFLEN+5), '(I2.2)') LINWID 494 BUFLEN = BUFLEN + 5 495 RETURN 496C 497C--- IFUNC=23, Escape -------------------------------------------------- 498C Note that the NOTHIN flag which indicates if there is anything 499C written on the paper is set here regardless of the content of 500C the escape characters. 501C 502 230 CONTINUE 503 IF (NOTHIN) NOTHIN = .FALSE. 504 IF (LCHR .GT. MAXLEN) THEN 505 WRITE (MSG(1:4), '(I4)') MAXLEN 506 CALL GRWARN('Sorry, maximum line size ('//MSG(1:4)// 507 : ') exceeded for device type QMS') 508 NBUF = -1 509 ELSE 510C 511C -- WARNING! Anyone using the escape mechanism to send stuff 512C to the QMS had better remember (a) the QMS is ASSUMED by 513C the driver to be in vector graphics mode, and (b) you better 514C darn well put it back in the same vector mode!!! If not, 515C well, you get what you deserve then. 516C 517 IF (BUFLEN+LCHR .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN) 518 BUFFER(BUFLEN+1:BUFLEN+LCHR) = CHR(1:LCHR) 519 BUFLEN = BUFLEN + LCHR 520 ENDIF 521C 522 RETURN 523C----------------------------------------------------------------------- 524 END 525 526C*GRQM00 -- PGPLOT QMS/QUIC driver, flush buffer 527C+ 528 SUBROUTINE GRQM00 (LUN, BUF, SIZ) 529 CHARACTER*(*) BUF 530 INTEGER LUN, SIZ 531C-- 532 WRITE (LUN, '(A)') BUF(1:SIZ) 533 BUF(1:LEN(BUF)) = ' ' 534 SIZ = 0 535 END 536