00001
00002 c
00003 c Copyright (c) 1986,1987,1988,1989,1990,1991,1992,1993,
00004 c by Steve McMillan, Drexel University, Philadelphia, PA.
00005 c
00006 c All rights reserved.
00007 c
00008 c Redistribution and use in source and binary forms are permitted
00009 c provided that the above copyright notice and this paragraph are
00010 c duplicated in all such forms and that any documentation,
00011 c advertising materials, and other materials related to such
00012 c distribution and use acknowledge that the software was developed
00013 c by the author named above.
00014 c
00015 c THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
00016 c IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
00017 c WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
00018 c
00019
00020 subroutine plot details
00021 save
00022 c
00023 c *****************************************************************
00024 c * *
00025 c * PLOT DETAILS: Translate plot commands for *
00026 c * specific output devices. *
00027 c * *
00028 c * *
00029 c * "Essential" commands are: *
00030 c * *
00031 c * weight set pen weight *
00032 c * color set pen color *
00033 c * background set background color *
00034 c * devon/off enable/disable output *
00035 c * to graphics device *
00036 c * graphin get graphic input *
00037 c * gfxin check if GIN is enabled *
00038 c * clear/erase erase all or part of screen *
00039 c * invert set foreground = background *
00040 c * point plot a single point/pixel *
00041 c * polydraw plot a polygon *
00042 c * polyfill plot a filled polygon *
00043 c * eop/newpage take new page *
00044 c * mcquit clean up and terminate graphics *
00045 c * *
00046 c * num_win number of open windows *
00047 c * set_win set (X) window *
00048 c * kill_win kill (X) window *
00049 c * curr_win current (X) window *
00050 c * iconify_win iconify current (X) window *
00051 c * iconify_all iconify all (X) windows *
00052 c * win_read_line get input from the current *
00053 c * (X) window *
00054 c * *
00055 c * Other routines (stored elsewhere): *
00056 c * *
00057 c * mcinit initialize graphics *
00058 c * plot move/draw a line *
00059 c * setfill set color for polyfill *
00060 c * *
00061 c *****************************************************************
00062 c
00063 external mcdxlinew !$pragma C (mcdxlinew)
00064 external mcdxcolor !$pragma C (mcdxcolor)
00065 external mcdxbackg !$pragma C (mcdxbackg)
00066 external mcdxpoint !$pragma C (mcdxpoint)
00067 external mcdxgin !$pragma C (mcdxgin)
00068 external mcdxpolyf !$pragma C (mcdxpolyf)
00069 external mcdxclear !$pragma C (mcdxclear)
00070 external mcdxreset !$pragma C (mcdxreset)
00071 external mcdxquit !$pragma C (mcdxquit)
00072 external mcdxidle !$pragma C (mcdxidle)
00073 external mcdxsetwin !$pragma C (mcdxsetwin)
00074 external mcdxkillwin !$pragma C (mcdxkillwin)
00075 external mcdxnopen !$pragma C (mcdxnopen)
00076 external mcdxread_line !$pragma C (mcdxread_line)
00077 external mcdxiconifywin !$pragma C (mcdxiconifywin)
00078 external mcdxiconifyall !$pragma C (mcdxiconifyall)
00079 external mcdxsetwincolormap !$pragma C (mcdxsetwincolormap)
00080 c
00081 dimension rpoly(1),spoly(1)
00082 c
00083 character*80 device
00084 character*10 chtekin,chout
00085 character*1 leadin
00086 character*1 tekin(10),tekout(10)
00087 character*1 vec(4)
00088 equivalence (chtekin,tekin),(chout,tekout)
00089 c
00090 character*1 ctrl(0:31),
00091 & null,ctrla,tab,lf,ff,cr,ctrlx,ctrlz,esc,gs,del
00092 common /ctrlch/ ctrl,
00093 & null,ctrla,tab,lf,ff,cr,ctrlx,ctrlz,esc,gs,del
00094 character*1 tekc(4),hpc(3),hpon(3),hpoff(6)
00095 common /dev controls/ tekc,hpc,hpon,hpoff
00096 c
00097 c Internal plotting variables:
00098 c
00099 common /dev status/ idevon,idevpen,idevwt
00100 common /dev details/ itek,ivers
00101 common /framesize/ nxpix,nx0,xfac,nypix,ny0,yfac
00102 common /last point/ rl,sl
00103 common /pen posn/ npo
00104 common /plain font/ wid
00105 common /plot device/ device,aspect,idev
00106 common /plot origin/ ro,so
00107 common /plot sizes/ xsize,ysize
00108 common /dev init/ init
00109 common /plot offset/ iin
00110 common /plot invert/ inv,ipensto
00111 save /plot invert/
00112 common /backgcolor/ ibackgcolor
00113 save /backgcolor/
00114 c
00115 c HP options:
00116 c ----------
00117 c
00118 common /hp plot/ ivdef
00119 c
00120 c TEK options:
00121 c -----------
00122 c
00123 common /input character/ leadin /input posn/ iposn,jposn
00124 c
00125 c PS option:
00126 c ---------
00127 c
00128 parameter (NSMAX = 100)
00129 common /ps strokes/ nstroke,nstrpage,nstroketot
00130 common /ps enforced/ ibounds,ps rmax,ps smax
00131 common /ps bounding box/ ixleft,iybot,ixright,iytop
00132 character*(*) id string
00133 c
00134 c SUN options:
00135 c -----------
00136 c
00137
00138 c
00139 common /graphproc/ igp
00140 common /mcpak_colormap/ ncolor,red(0:255),green(0:255),
00141 & blue(0:255)
00142 common /sunscreen/ isun
00143 common /findex/ index
00144 dimension xbox(4),ybox(4)
00145 c
00146 c X options:
00147 c ---------
00148 c
00149 logical gfxin
00150 character*(*) filename
00151 c
00152 data ibounds/1/
00153 c
00154 c-----------------------------------------------------------------------
00155 c
00156 entry getstatus(jgdevice,jgdevon,jgdevpen,jgdevwt)
00157 c ***************
00158 c Return overall device status. * GETSTATUS *
00159 c ***************
00160 jgdevice = idev
00161 jgdevon = idevon
00162 jgdevpen = idevpen
00163 jgdevwt = idevwt
00164 c
00165 return
00166 c
00167 c-----------------------------------------------------------------------
00168 c
00169 entry weight(iwt)
00170 c ************
00171 c Adjust pen width/weight, if appropriate. * WEIGHT *
00172 c ************
00173 c
00174 c CONVENTION: Fiddle with details so that 1 is a "thin" line,
00175 c 10 is a "double weight" line, 20 is a "heavy"
00176 c line, etc., independent of the device.
00177 c
00178 if(idev.eq.1)then
00179 write(60,500)4,char(modulo(iwt,64)+32)
00180 500 format(i1,a1)
00181 else if((idev.eq.5.or.idev.eq.6).and.iwt.ne.idevwt)then
00182 c
00183 c HP GL (what does "weight" mean here?)
00184 c
00185 if(idevon.le.0)write(6,510)hpon
00186 510 format(1x,10a1)
00187 jpen = max(0,min(7,iwt))
00188 write(6,520)jpen+1,ivdef*(11-jpen)
00189 520 format(' FS',i1,';VS',i2,';')
00190 if(idevon.le.0)write(6,510)hpoff
00191 c
00192 else if((idev.eq.7.or.idev.eq.8.or.idev.eq.11.or.idev.eq.12)
00193 & .and.iwt.gt.0)then
00194 c
00195 c Tek/Versaterm -- pensize specifies pen size in pixels.
00196 c
00197 iw = (iwt+4)/10+1
00198 call pensize(iw,iw)
00199 c
00200 else if((idev.eq.15))then
00201 c
00202 c SunCore ideosyncrasies:
00203 c
00204 c setlinewidth(x) --> single for 0.0 to 0.3
00205 c double for 0.4, 0.5
00206 c heavy for 0.6
00207 c heavier for 0.7
00208 c heavier still for 0.8, 0.9
00209 c ...
00210 c
00211 if (iwt.le.5) then
00212 ww = 0.1
00213 else if (iwt.le.15) then
00214 ww = 0.4 + 0.01*(iwt-5)
00215 else
00216 ww = 0.6 + 0.01*(iwt-15)
00217 end if
00218 call setlinewidth(ww)
00219 c
00220 else if(idev.eq.16)then
00221 c
00222 c PostScript.
00223 c
00224 call ps stroke
00225 write(42,'(f5.1,'' setlinewidth'')').1*iwt
00226 write(42,'(''2 setlinejoin 2 setlinecap'')')
00227 c
00228 c N.B. PS weight applies to SUBSEQUENT lines only.
00229 c
00230 else if (idev.eq.17) then
00231 jwt = max(0, nint(.1*iwt+.5))
00232 call mcdxlinew(jwt)
00233 end if
00234 c
00235 idevwt = iwt
00236 c
00237 return
00238 c
00239 c-----------------------------------------------------------------------
00240 c
00241 entry pen(ipenin)
00242 c ***************
00243 c Set pen characteristics ("color"). * PEN/COLOR *
00244 c ***************
00245 ipen = ipenin
00246 525 if(idev.eq.1)then
00247 write(60,500)5,char(modulo(ipen,64)+32)
00248 else if((idev.eq.5.or.idev.eq.6).and.ipen.ne.idevpen)then
00249 if(idevon.le.0)write(6,510)hpon
00250 write(6,530)max(0,min(8,ipen))
00251 530 format(' SP',i1,';')
00252 if(idevon.le.0)write(6,510)hpoff
00253 idevpen = ipen
00254 else if(idev.eq.13.or.idev.eq.14)then
00255 call output char(esc)
00256 write(chout,531)min(7,max(0,ipen))
00257 531 format('ML',i1)
00258 call type string(tekout,3)
00259 else if(idev.eq.15)then
00260 call setlineindex(ipen)
00261 call settextindex(ipen)
00262 c Note that ipen = 0 erases
00263 else if(idev.eq.16)then
00264 call ps color(ipen)
00265 c
00266 c N.B. PS pen color applies to SUBSEQUENT lines only.
00267 c
00268 else if (idev.eq.17) then
00269 c
00270 c For now, just wrap the colormap...
00271 c
00272 jpen = ipen/ncolor
00273 if (jpen.gt.0) ipen = ipen - ncolor*jpen
00274 call mcdxcolor(ipen)
00275 end if
00276 idevpen = ipen
00277 c
00278 return
00279 c
00280 entry color(icolor)
00281 c
00282 ipen = icolor
00283 go to 525
00284 c
00285 entry getcolor(jcolor)
00286 jcolor = idevpen
00287 return
00288 c
00289 c-----------------------------------------------------------------------
00290 c
00291 entry background(iback)
00292 c ****************
00293 c Set background color. * BACKGROUND *
00294 c ****************
00295 if (idev.eq.15) then
00296 call corebackg(iback)
00297 else if (idev.eq.17) then
00298 c
00299 c For now, just wrap the colormap...
00300 c
00301 jback = iback/ncolor
00302 if (jback.gt.0) iback = iback - ncolor*jback
00303 call mcdxbackg(iback)
00304 end if
00305 c
00306 ibackgcolor = iback
00307 c
00308 return
00309 c
00310 c-----------------------------------------------------------------------
00311 c
00312 entry devon
00313 c ***********
00314 c Explicitly initiate output to graphics device. * DEVON *
00315 c ***********
00316 if (idevon.ne.1) then
00317 if(itek.eq.1)then
00318 if(ivers.eq.0)then
00319 if (idev.eq.9.or.idev.eq.10) then
00320 c
00321 c Xterm escape sequences:
00322 c
00323 call output char(esc)
00324 call output char('[')
00325 call output char('?')
00326 call output char('3')
00327 call output char('8')
00328 call output char('h')
00329 else
00330 call output char(esc)
00331 call output char(';')
00332 write(6,*)
00333 end if
00334 end if
00335 call output char(gs)
00336 else if(idev.eq.5.or.idev.eq.6)then
00337 write(6,510)hpon
00338 end if
00339 idevon = 1
00340 end if
00341 return
00342 c
00343 c-----------------------------------------------------------------------
00344 c
00345 entry devoff
00346 c ************
00347 c Explicitly terminate output to graphics device. * DEVOFF *
00348 c ************
00349 iquit = 0
00350 c
00351 200 if (idevon.ne.0) then
00352 c
00353 if (itek.eq.1) then
00354 if (ivers.eq.0) then
00355 if (idev.eq.9.or.idev.eq.10) then
00356 c
00357 c Xterm escape sequences:
00358 c
00359 c Flush the buffer (100 may be overkill, but...).
00360 c
00361 call plot(-10.,-10.,3)
00362 do 210 i=1,100
00363 call plot(-10.,-10.,2)
00364 210 continue
00365 c
00366 call output char(esc)
00367 call output char(char(3))
00368 c
00369 else
00370 call plot(-10.,-10.,3)
00371 call plot(-10.,-10.,2)
00372 end if
00373 end if
00374 call output char(esc)
00375 call output char('2')
00376 c
00377 else if(idev.eq.5.or.idev.eq.6)then
00378 write(6,510)hpoff
00379 npo = 3
00380 end if
00381 c
00382 idevon = 0
00383 c
00384 end if
00385 c
00386 if (iquit.eq.1) then
00387 c
00388 c Complete MCQUIT operations.
00389 c
00390 init = 0
00391 idev = 0
00392 device = ' '
00393 iin = 0
00394 end if
00395 c
00396 return
00397 c
00398 c-----------------------------------------------------------------------
00399 c
00400 entry graphin(r,s)
00401 c
00402 c Return the location of the graphics pointer relative *************
00403 c to the current origin (implemented for Tektronix, X, * GRAPHIN *
00404 c and SUN options only). *************
00405 c
00406 if (.not.gfxin()) return
00407 c
00408 if(idev.eq.15)then
00409 kount = 0
00410 400 call awtbuttongetloc2(0,1,ibutton,xx,yy)
00411 if(ibutton.eq.0)then
00412 kount = kount+1
00413 if(kount.lt.12000)then
00414 call uwait(5000)
00415 go to 400
00416 end if
00417 write(6,*)'timed out...'
00418 xx = 0.
00419 yy = 0.
00420 end if
00421 c
00422 r = xsize*xx-ro
00423 s = xsize*yy-so
00424 c Yes, this SHOULD be xsize!!
00425 c
00426 iposn = 1000*xx
00427 jposn = 1000*yy
00428 return
00429 else if (idev.eq.17) then
00430 call mcdxgin(r,s)
00431 iposn = nxpix*r/xsize
00432 jposn = nypix*s/ysize
00433 r = r - ro
00434 s = s - so
00435 return
00436 end if
00437 c
00438 if (itek.eq.0) return
00439 c
00440 c The rest is for Tektronix mode(s).
00441 c
00442 if (idevon.eq.0) then
00443 if (idev.eq.9.or.idev.eq.10) then
00444 call output char(esc)
00445 call output char('[')
00446 call output char('?')
00447 call output char('3')
00448 call output char('8')
00449 call output char('h')
00450 else
00451 call output char(gs)
00452 end if
00453 idevon = 1
00454 end if
00455 c
00456 c enter gin mode...
00457 c
00458 call output char(esc)
00459 call output char(ctrlz)
00460 c
00461 c ...read the pointer address, preceded by a lead-in character...
00462 c
00463 if(nxpix.gt.1023)then
00464 kmax = 6
00465 else
00466 kmax = 5
00467 end if
00468 c do 95 k=1,kmax
00469 do 95 k=1,kmax
00470 call input char(tekin(k))
00471 if((tekin(k).eq.lf.or.tekin(k).eq.cr).and.k.gt.1)go to 96
00472 95 continue
00473 k = kmax+1
00474 96 kmax = k-1
00475 c
00476 c ...and exit gin mode.
00477 c
00478 if (idev.ne.9.and.idev.ne.10) then
00479 call output char(cr)
00480 else
00481 c
00482 c Xterm version -- leave GFX mode:
00483 c
00484 call output char(esc)
00485 call output char(char(3))
00486 idevon = 0
00487 end if
00488 c
00489 c Each use of graphin causes the tektronix to go out of graph
00490 c mode momentarily, so we must reposition the pointer:
00491 c
00492 call plot(rl,sl,3)
00493 c
00494 c This will also undo VersaTerm "inverted" mode, so reset, if necessary:
00495 c
00496 if(inv.eq.1)then
00497 call output char(esc)
00498 if(idev.eq.14)then
00499 chout = 'ML0'
00500 call type string(tekout,3)
00501 else
00502 call output char(del)
00503 end if
00504 end if
00505 c
00506 c Now decode the address from tekin(2),...,tekin(kmax).
00507 c note that the input string is encoded differently from the
00508 c corresponding output in plot or pixel.
00509 c
00510 i32 = 32
00511 c (force integer*4 arithmetic below)
00512 c
00513 if(kmax.eq.5)then
00514 i = (ichar(tekin(2))-32)*i32 + (ichar(tekin(3))-32)
00515 j = (ichar(tekin(4))-32)*i32 + (ichar(tekin(5))-32)
00516 if(nxpix.gt.1023)then
00517 i = 4*i
00518 j = 4*j
00519 end if
00520 else
00521 c
00522 c This possibility might not actually be legal. It is
00523 c not yet tested.
00524 c
00525 ii = ichar(tekin(5))-32
00526 jj = ii/4
00527 ii = ii-4*jj
00528 i = 4*((ichar(tekin(2))-32)*i32 + (ichar(tekin(3))-32)) + ii
00529 j = 4*((ichar(tekin(4))-32)*i32 + (ichar(tekin(6))-32)) + jj
00530 end if
00531 r = (i-nx0)/xfac-ro
00532 s = (j-ny0)/yfac-so
00533 iposn = i
00534 jposn = j
00535 leadin = chtekin(1:1)
00536 if(idevon.le.0)then
00537 call output char(esc)
00538 call output char('2')
00539 end if
00540 return
00541 c
00542 c-----------------------------------------------------------------------
00543 c
00544 entry erase(rmin,rmax,smin,smax)
00545 c ***********
00546 c Clear a rectangular region of the display (for * ERASE *
00547 c SUN, X, PostScript and "Versaterm" options only) ***********
00548 c
00549 if(idev.eq.15.or.idev.eq.16.or.idev.eq.17)then
00550 xbox(1) = rmin
00551 xbox(2) = rmax
00552 xbox(3) = rmax
00553 xbox(4) = rmin
00554 ybox(1) = smin
00555 ybox(2) = smin
00556 ybox(3) = smax
00557 ybox(4) = smax
00558 call polyerase(xbox,ybox,4)
00559 end if
00560 c
00561 if(ivers.eq.0)return
00562 c
00563 if(idevon.le.0)then
00564 call output char(gs)
00565 idevon = 1
00566 end if
00567 c
00568 if(1.eq.0.and.idev.ge.8.and.idev.le.12)then
00569 c
00570 c if pensize doesn't work, use this...
00571 c
00572 i1 = (rmin+ro)*xfac+nx0
00573 i2 = (rmax+ro)*xfac+nx0
00574 j1 = (smin+so)*yfac+ny0
00575 j2 = (smax+so)*yfac+ny0
00576 call output char(esc)
00577 call output char(del)
00578 if(i2-i1.gt.j2-j1)then
00579 do 11001 j=j1,j2
00580 call pixel(i1,j,3)
00581 call pixel(i2,j,2)
00582 11001 continue
00583 else
00584 do 11002 i=i1,i2
00585 call pixel(i,j1,3)
00586 call pixel(i,j2,2)
00587 11002 continue
00588 end if
00589 call output char(cr)
00590 return
00591 else if(idev.lt.13)then
00592 i = 0
00593 j = (smax-smin)*yfac+1
00594 call pensize(i,j)
00595 c
00596 c turn on erase mode:
00597 c
00598 call output char(esc)
00599 call output char(del)
00600 c
00601 c draw the line:
00602 c
00603 call plot(rmin,smax,3)
00604 call plot(rmax,smax,2)
00605 c
00606 c reset:
00607 c
00608 call output char(cr)
00609 else if(idev.eq.14)then
00610 call output char(esc)
00611 chout = 'MP0'
00612 call type string(tekout,3)
00613 call output char(esc)
00614 chout = 'LP'
00615 call type string(tekout,2)
00616 call xyencode(rmin,smin,vec)
00617 call type string(vec,5)
00618 call type string(tekout,2)
00619 call plot(rmin,smax,2)
00620 call plot(rmax,smax,2)
00621 call plot(rmax,smin,2)
00622 call plot(rmin,smin,2)
00623 call output char(esc)
00624 chout = 'LE'
00625 call type string(tekout,2)
00626 end if
00627 return
00628 c
00629 c-----------------------------------------------------------------------
00630 c
00631 entry clear
00632 c ***********
00633 c clear entire screen, if any,... * CLEAR *
00634 c ***********
00635 if (idev.eq.1) then
00636 write(60,500)6
00637 else if (idev.eq.15) then
00638 call plframe
00639 else if (idev.eq.16) then
00640 c
00641 c Old version:
00642 c
00643 c write(42,'(''erasepage'')')
00644 c
00645 c New version (saves unnecessary output to the printer):
00646 c Close the output file, and copy it to a new file, omitting
00647 c all "plot" commands.
00648 c
00649 write(42,'(/''%Re-writing...''/)')
00650 call ps rewrite
00651 ixleft = 10000
00652 iybot = 10000
00653 ixright = 0
00654 iytop = 0
00655 c
00656 nstroke = 0
00657 nstrpage = 0
00658 nstroketot = 0
00659 else if (idev.eq.17) then
00660 call mcdxclear
00661 else if (itek.eq.1) then
00662 if(idev.eq.12.or.idev.eq.14)then
00663 call output char(esc)
00664 call output char(ff)
00665 else
00666 call type string(tekc,4)
00667 end if
00668 if(ivers.eq.0)then
00669 call plot(-10.,10.,3)
00670 call plot(-10.,10.,2)
00671 end if
00672 end if
00673 return
00674 c
00675 c-----------------------------------------------------------------------
00676 c
00677 entry invert
00678 c ************
00679 c Toggle between draw and undraw modes (SUN, * INVERT *
00680 c PostScript, X and Versaterm modes only). ************
00681 c
00682 if (idev.eq.15.or.idev.eq.16.or.idev.eq.17) then
00683 if(idevpen.gt.0)then
00684 ipensto = idevpen
00685 idevpen = 0
00686 else
00687 idevpen = ipensto
00688 end if
00689 c
00690 if(idev.eq.15)then
00691 call setlineindex(idevpen)
00692 else if (idev.eq.16) then
00693 call ps color(idevpen)
00694 else if (idev.eq.17) then
00695 call mcdxcolor(idevpen)
00696 end if
00697 return
00698 end if
00699 c
00700 if (idev.ne.7.and.idev.ne.8.and.idev.ne.10
00701 & .and.idev.ne.12.and.idev.ne.14) return
00702 c
00703 if(idevon.le.0)then
00704 call output char(gs)
00705 idevon = 1
00706 end if
00707 if(inv.eq.0)then
00708 call output char(esc)
00709 if(idev.eq.14)then
00710 chout = 'ML0'
00711 call type string(tekout,3)
00712 else
00713 call output char(del)
00714 end if
00715 inv = 1
00716 else
00717 if(idev.eq.14)then
00718 call output char(esc)
00719 chout = 'ML1'
00720 call type string(tekout,3)
00721 else
00722 call output char(cr)
00723 end if
00724 inv = 0
00725 end if
00726 c
00727 c Note that we have probably lost track of the graphics pointer
00728 c through this action.
00729 c
00730 return
00731 c
00732 c-----------------------------------------------------------------------
00733 c
00734 entry point(r,s)
00735 c ***********
00736 c Plot a single point. * POINT *
00737 c ***********
00738 if(idev.eq.16)then
00739 rr = nx0+xfac*(r+ro)
00740 ss = ny0+yfac*(s+so)
00741 if(ibounds.ne.0)then
00742 rr = max(0.,min(ps rmax,rr))
00743 ss = max(0.,min(ps smax,ss))
00744 end if
00745 write(42,'(f7.3,f8.3,'' p%'')')rr,ss
00746 if(nstroke.ge.NSMAX/2)then
00747 call ps stroke
00748 write(42,'(f7.3,f8.3,'' m%'')')rr,ss
00749 end if
00750 nstroke = nstroke+1
00751 nstrpage = nstrpage+1
00752 nstroketot = nstroketot+1
00753 else if (idev.eq.17) then
00754 call mcdxpoint(r+ro,s+so)
00755 else
00756 call plot(r,s,3)
00757 call plot(r,s,2)
00758 end if
00759 c
00760 return
00761 c
00762 c-----------------------------------------------------------------------
00763 c
00764 entry polydraw(rpoly,spoly,npoly)
00765 c **************
00766 c Draw a regular polygon. * POLYDRAW *
00767 c **************
00768 call plot(rpoly(npoly),spoly(npoly),3)
00769 do 10 i = 1,npoly
00770 call plot(rpoly(i),spoly(i),2)
00771 10 continue
00772 c
00773 return
00774 c
00775 c-----------------------------------------------------------------------
00776 c
00777 entry polyfill(rpoly,spoly,npoly)
00778 c **************
00779 c Draw a filled regular polygon. * POLYFILL *
00780 c **************
00781 if((idev.ne.15.and.idev.ne.16.and.idev.ne.17)
00782 & .or.index.lt.0) return
00783 c
00784 if (idev.eq.15.or.idev.eq.17) then
00785 c
00786 c SunCore/X want absolute coordinates.
00787 c
00788 do 110 i=1,npoly
00789 rpoly(i) = rpoly(i) + ro
00790 spoly(i) = spoly(i) + so
00791 110 continue
00792 end if
00793 c
00794 if(idev.eq.15)then
00795 c
00796 call polygonabs2(rpoly,spoly,npoly)
00797 c
00798 else if (idev.eq.16) then
00799 c
00800 call ps color(index)
00801 c
00802 call plot(rpoly(npoly),spoly(npoly),3)
00803 do 120 i=1,npoly
00804 call plot(rpoly(i),spoly(i),2)
00805 120 continue
00806 write(42,'(''fill'')')
00807 call ps color(ipen)
00808 c
00809 else if (idev.eq.17) then
00810 c
00811 call mcdxpolyf(rpoly,spoly,npoly,index)
00812 c
00813 end if
00814 c
00815 if (idev.eq.15.or.idev.eq.17) then
00816 do 130 i=1,npoly
00817 rpoly(i) = rpoly(i) - ro
00818 spoly(i) = spoly(i) - so
00819 130 continue
00820 end if
00821 c
00822 return
00823 c
00824 c-----------------------------------------------------------------------
00825 c
00826 entry bounded
00827 entry bounds
00828 c *************
00829 c Enforce/don't enforce xsize x ysize bounds * BOUNDED *
00830 c on (currently, only PostScript) output. *************
00831 c
00832 ibounds = 1
00833 return
00834 c
00835 entry unbounded
00836 entry nobounds
00837 ibounds = 0
00838 return
00839 c
00840 c-----------------------------------------------------------------------
00841 c
00842 entry eop
00843 entry newp
00844 entry newplot
00845 entry nextplot
00846 entry newpage
00847 c ***************
00848 c End plot, prepare for new one (flush buffer, * EOP, etc. *
00849 c clear screen, etc.),... ***************
00850 c
00851 if(idev.eq.1)then
00852 write(60,500)7
00853 else if(idev.eq.2)then
00854 call frame
00855 else if(itek.eq.1)then
00856 call display text(
00857 & 'Enter <CR> to clear screen. ',40)
00858 read(5,350)idummy
00859 350 format(a1)
00860 if(idev.ne.13.and.idev.ne.14)then
00861 call type string(tekc,4)
00862 else
00863 call output char(esc)
00864 call output char(ff)
00865 end if
00866 else if(idev.eq.5.or.idev.eq.6)then
00867 if(idevon.le.0)write(6,510)hpon
00868 write(6,510)hpc
00869 if(idevon.le.0)write(6,510)hpoff
00870 else if(idev.eq.15)then
00871 call sunwait
00872 call plframe
00873 else if(idev.eq.16)then
00874 call ps page(1)
00875 else if (idev.eq.17) then
00876 write(6,6000)
00877 6000 format('Click right-hand mouse button'
00878 $ ' in window to exit X.')
00879 call mcdxidle
00880 call mcdxreset
00881 end if
00882 go to 200
00883 c
00884 c-----------------------------------------------------------------------
00885 c
00886 entry set_win(iwin, iret)
00887 c ***************
00888 c Choose output window. * SET_WIN *
00889 c ***************
00890 c
00891 if (idev.eq.17) then
00892 iret = mcdxsetwin(iwin)
00893 c
00894 c Return status is -1 on error.
00895 c
00896 end if
00897 c
00898 return
00899 c
00900 c-----------------------------------------------------------------------
00901 c
00902 entry kill_win(iwin)
00903 c ***************
00904 c Kill output window. * KILL_WIN *
00905 c ***************
00906 c
00907 if (idev.eq.17) then
00908 call mcdxkillwin(iwin)
00909 if (mcdxnopen().le.0) then
00910 c
00911 c No windows left!
00912 c
00913 idev = 0
00914 device = ' '
00915 iin = 0
00916 idevon = 0
00917 end if
00918 end if
00919 c
00920 return
00921 c
00922 c-----------------------------------------------------------------------
00923 c
00924 entry iconify_win(iwin)
00925 c ***************
00926 c Iconify an output X window. * ICONIFY_WIN *
00927 c ***************
00928 c
00929 call mcdxiconifywin(iwin)
00930 c
00931 return
00932 c
00933 c-----------------------------------------------------------------------
00934 c
00935 entry iconify_all
00936 c ***************
00937 c Iconify all output X windows. * ICONIFY_ALL *
00938 c ***************
00939 c
00940 call mcdxiconifyall()
00941 c
00942 return
00943 c
00944 c-----------------------------------------------------------------------
00945 c
00946 entry set_colormap(filename,ier)
00947 c ***************
00948 c Load a colormap from a file. * SET_COLORMAP*
00949 c ***************
00950 c
00951 nf = 0
00952 do i=len(filename),1,-1
00953 if (nf.eq.0.and.filename(i:i).gt.' ') nf = i
00954 end do
00955 c
00956 c HP fortran doesn't understand '\0'...
00957 c
00958 call mcdxsetwincolormap(filename(1:nf) )
00959 c
00960 return
00961 c
00962 c-----------------------------------------------------------------------
00963 c
00964 entry win_read_line(string)
00965 c *****************
00966 c Read a line of text from the (X) window system. * WIN_READ_LINE *
00967 c *****************
00968 c
00969 if (mcdxnopen().gt.0) then
00970 call mcdxread_line(string)
00971 end if
00972 c
00973 return
00974 c
00975 c-----------------------------------------------------------------------
00976 c
00977 entry routine id(id string)
00978 c ****************
00979 c Identify key routines. * ROUTINE ID *
00980 c ****************
00981 c
00982 if (idev.eq.16) then
00983 do 450 i=len(id string),1,-1
00984 if (id string(i:i).gt.' ') go to 455
00985 450 continue
00986 return
00987 455 write(42,'(''%%% Routine '',a,'':'')')id string(1:i)
00988 end if
00989 c
00990 return
00991 c
00992 c-----------------------------------------------------------------------
00993 c
00994 entry mcquit
00995 iquit = 0
00996 go to 1000
00997 c
00998 entry mcquit1
00999 iquit = 1
01000 c ************
01001 c Terminate graphics session. * MCQUIT *
01002 c ************
01003 1000 if (isun.gt.0) then
01004 write(6,'(''Enter <CR> to terminate graphics.'')')
01005 call plstop
01006 isun = 0
01007 end if
01008 c
01009 c NOTE: The system call in psquit apparently requires that SunCore
01010 c graphics be terminated before attempting to print any PostScript file.
01011 c
01012 call psquit
01013 c
01014 c Call to psquit does nothing if no PS device is open.
01015 c
01016 if (mcdxnopen().gt.0) then
01017 if (iquit.eq.1) then
01018 write(6,6001)
01019 6001 format('Click right-hand mouse button in current'
01020 $ ' window to exit X.')
01021 call mcdxidle
01022 end if
01023 end if
01024 c
01025 call mcdxquit
01026 c
01027 c Remaining termination is done by devoff (label 200).
01028 c
01029 iquit = 1
01030 go to 200
01031 c
01032 end
01033
01034
01035 logical function gfxin()
01036 save
01037 c ***********
01038 c Return TRUE iff graphin will work. * GFXIN *
01039 c ***********
01040 character*80 device
01041 common /plot device/ device,aspect,idev
01042 common /dev details/ itek,ivers
01043 c
01044 if (idev.eq.15.or.idev.eq.17.or.itek.eq.1
01045 c & .or.(itek.eq.1.and.idev.ne.9.and.idev.ne.10)
01046 & ) then
01047 gfxin = .true.
01048 else
01049 gfxin = .false.
01050 end if
01051 c
01052 end
01053
01054
01055 integer function num_win(id)
01056 save
01057 c ***********
01058 c Return the number of open windows associated with id. * NUM_WIN *
01059 c ***********
01060 character*80 device
01061 common /plot device/ device,aspect,idev
01062 c
01063 logical ps_open
01064 external mcdxnopen !$pragma C (mcdxnopen)
01065 c
01066 num_win = 0
01067 if (id.gt.0) then
01068 c
01069 c PostScript and X can be open without being active.
01070 c
01071 if (id.eq.16) then
01072 if (ps_open()) num_win = 1
01073 else if (id.eq.17) then
01074 num_win = mcdxnopen()
01075 else
01076 if (id.eq.idev) num_win = 1
01077 end if
01078 end if
01079 c
01080 end
01081
01082
01083 integer function curr_win()
01084 save
01085 c ************
01086 c Return the current output window. * CURR_WIN *
01087 c ************
01088 character*80 device
01089 common /plot device/ device,aspect,idev
01090 c
01091 external mcdxcurrwin !$pragma C (mcdxcurrwin)
01092 c
01093 if (idev.le.0) then
01094 curr_win = -1
01095 else
01096 curr_win = 0
01097 if (idev.eq.17) curr_win = mcdxcurrwin()
01098 end if
01099 c
01100 end
01101
01102
01103 subroutine polyerase(r,s,n)
01104 save
01105 c
01106 c Erase the specified polygonal area.
01107 c
01108 external mcdxpolyf !$pragma C (mcdxpolyf)
01109 c
01110 dimension r(1),s(1)
01111 character*80 device
01112 common /plot device/ device,aspect,idev
01113 common /plot origin/ ro,so
01114 common /backgcolor/ ibackgcolor
01115 save /backgcolor/
01116 c
01117 if(idev.eq.15)then
01118 c
01119 c Switch to absolute coordinates:
01120 c
01121 do k=1,n
01122 r(k) = r(k) + ro
01123 s(k) = s(k) + so
01124 end do
01125 c
01126 call setfillindex(0)
01127 call polygonabs2(r,s,n)
01128 c
01129 do k=1,n
01130 r(k) = r(k) - ro
01131 s(k) = s(k) - so
01132 end do
01133 c
01134 else if(idev.eq.16)then
01135 c
01136 call ps stroke
01137 call plot(r(n),s(n),3)
01138 do i=1,n
01139 call plot(r(i),s(i),2)
01140 end do
01141 write(42,'(''1.0 setgray''/''fill''/f5.3,'' setgray'')')
01142 & ipen/256.
01143 call ps color(ipen)
01144 c
01145 else if (idev.eq.17) then
01146 c
01147 c Switch to absolute coordinates:
01148 c
01149 do k=1,n
01150 r(k) = r(k) + ro
01151 s(k) = s(k) + so
01152 end do
01153 c
01154 call mcdxpolyf(r,s,n,ibackgcolor)
01155 c
01156 do k=1,n
01157 r(k) = r(k) - ro
01158 s(k) = s(k) - so
01159 end do
01160 c
01161 end if
01162 c
01163 end
01164
01165
01166 c
01167 c Copyright (c) 1986,1987,1988,1989,1990,1991,1992,1993,
01168 c by Steve McMillan, Drexel University, Philadelphia, PA.
01169 c
01170 c All rights reserved.
01171 c
01172 c Redistribution and use in source and binary forms are permitted
01173 c provided that the above copyright notice and this paragraph are
01174 c duplicated in all such forms and that any documentation,
01175 c advertising materials, and other materials related to such
01176 c distribution and use acknowledge that the software was developed
01177 c by the author named above.
01178 c
01179 c THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
01180 c IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
01181 c WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
01182 c
01183
01184 subroutine plot details
01185 save
01186 c
01187 c *****************************************************************
01188 c * *
01189 c * PLOT DETAILS: Translate plot commands for *
01190 c * specific output devices. *
01191 c * *
01192 c * *
01193 c * "Essential" commands are: *
01194 c * *
01195 c * weight set pen weight *
01196 c * color set pen color *
01197 c * background set background color *
01198 c * devon/off enable/disable output *
01199 c * to graphics device *
01200 c * graphin get graphic input *
01201 c * gfxin check if GIN is enabled *
01202 c * clear/erase erase all or part of screen *
01203 c * invert set foreground = background *
01204 c * point plot a single point/pixel *
01205 c * polydraw plot a polygon *
01206 c * polyfill plot a filled polygon *
01207 c * eop/newpage take new page *
01208 c * mcquit clean up and terminate graphics *
01209 c * *
01210 c * num_win number of open windows *
01211 c * set_win set (X) window *
01212 c * kill_win kill (X) window *
01213 c * curr_win current (X) window *
01214 c * iconify_win iconify current (X) window *
01215 c * iconify_all iconify all (X) windows *
01216 c * win_read_line get input from the current *
01217 c * (X) window *
01218 c * *
01219 c * Other routines (stored elsewhere): *
01220 c * *
01221 c * mcinit initialize graphics *
01222 c * plot move/draw a line *
01223 c * setfill set color for polyfill *
01224 c * *
01225 c *****************************************************************
01226 c
01227 external mcdxlinew !$pragma C (mcdxlinew)
01228 external mcdxcolor !$pragma C (mcdxcolor)
01229 external mcdxbackg !$pragma C (mcdxbackg)
01230 external mcdxpoint !$pragma C (mcdxpoint)
01231 external mcdxgin !$pragma C (mcdxgin)
01232 external mcdxpolyf !$pragma C (mcdxpolyf)
01233 external mcdxclear !$pragma C (mcdxclear)
01234 external mcdxreset !$pragma C (mcdxreset)
01235 external mcdxquit !$pragma C (mcdxquit)
01236 external mcdxidle !$pragma C (mcdxidle)
01237 external mcdxsetwin !$pragma C (mcdxsetwin)
01238 external mcdxkillwin !$pragma C (mcdxkillwin)
01239 external mcdxnopen !$pragma C (mcdxnopen)
01240 external mcdxread_line !$pragma C (mcdxread_line)
01241 external mcdxiconifywin !$pragma C (mcdxiconifywin)
01242 external mcdxiconifyall !$pragma C (mcdxiconifyall)
01243 external mcdxsetwincolormap !$pragma C (mcdxsetwincolormap)
01244 c
01245 dimension rpoly(1),spoly(1)
01246 c
01247 character*80 device
01248 character*10 chtekin,chout
01249 character*1 leadin
01250 character*1 tekin(10),tekout(10)
01251 character*1 vec(4)
01252 equivalence (chtekin,tekin),(chout,tekout)
01253 c
01254 character*1 ctrl(0:31),
01255 & null,ctrla,tab,lf,ff,cr,ctrlx,ctrlz,esc,gs,del
01256 common /ctrlch/ ctrl,
01257 & null,ctrla,tab,lf,ff,cr,ctrlx,ctrlz,esc,gs,del
01258 character*1 tekc(4),hpc(3),hpon(3),hpoff(6)
01259 common /dev controls/ tekc,hpc,hpon,hpoff
01260 c
01261 c Internal plotting variables:
01262 c
01263 common /dev status/ idevon,idevpen,idevwt
01264 common /dev details/ itek,ivers
01265 common /framesize/ nxpix,nx0,xfac,nypix,ny0,yfac
01266 common /last point/ rl,sl
01267 common /pen posn/ npo
01268 common /plain font/ wid
01269 common /plot device/ device,aspect,idev
01270 common /plot origin/ ro,so
01271 common /plot sizes/ xsize,ysize
01272 common /dev init/ init
01273 common /plot offset/ iin
01274 common /plot invert/ inv,ipensto
01275 save /plot invert/
01276 common /backgcolor/ ibackgcolor
01277 save /backgcolor/
01278 c
01279 c HP options:
01280 c ----------
01281 c
01282 common /hp plot/ ivdef
01283 c
01284 c TEK options:
01285 c -----------
01286 c
01287 common /input character/ leadin /input posn/ iposn,jposn
01288 c
01289 c PS option:
01290 c ---------
01291 c
01292 parameter (NSMAX = 100)
01293 common /ps strokes/ nstroke,nstrpage,nstroketot
01294 common /ps enforced/ ibounds,ps rmax,ps smax
01295 common /ps bounding box/ ixleft,iybot,ixright,iytop
01296 character*(*) id string
01297 c
01298 c SUN options:
01299 c -----------
01300 c
01301
01302 c
01303 common /graphproc/ igp
01304 common /mcpak_colormap/ ncolor,red(0:255),green(0:255),
01305 & blue(0:255)
01306 common /sunscreen/ isun
01307 common /findex/ index
01308 dimension xbox(4),ybox(4)
01309 c
01310 c X options:
01311 c ---------
01312 c
01313 logical gfxin
01314 character*(*) filename
01315 c
01316 data ibounds/1/
01317 c
01318 c-----------------------------------------------------------------------
01319 c
01320 entry getstatus(jgdevice,jgdevon,jgdevpen,jgdevwt)
01321 c ***************
01322 c Return overall device status. * GETSTATUS *
01323 c ***************
01324 jgdevice = idev
01325 jgdevon = idevon
01326 jgdevpen = idevpen
01327 jgdevwt = idevwt
01328 c
01329 return
01330 c
01331 c-----------------------------------------------------------------------
01332 c
01333 entry weight(iwt)
01334 c ************
01335 c Adjust pen width/weight, if appropriate. * WEIGHT *
01336 c ************
01337 c
01338 c CONVENTION: Fiddle with details so that 1 is a "thin" line,
01339 c 10 is a "double weight" line, 20 is a "heavy"
01340 c line, etc., independent of the device.
01341 c
01342 if(idev.eq.1)then
01343 write(60,500)4,char(modulo(iwt,64)+32)
01344 500 format(i1,a1)
01345 else if((idev.eq.5.or.idev.eq.6).and.iwt.ne.idevwt)then
01346 c
01347 c HP GL (what does "weight" mean here?)
01348 c
01349 if(idevon.le.0)write(6,510)hpon
01350 510 format(1x,10a1)
01351 jpen = max(0,min(7,iwt))
01352 write(6,520)jpen+1,ivdef*(11-jpen)
01353 520 format(' FS',i1,';VS',i2,';')
01354 if(idevon.le.0)write(6,510)hpoff
01355 c
01356 else if((idev.eq.7.or.idev.eq.8.or.idev.eq.11.or.idev.eq.12)
01357 & .and.iwt.gt.0)then
01358 c
01359 c Tek/Versaterm -- pensize specifies pen size in pixels.
01360 c
01361 iw = (iwt+4)/10+1
01362 call pensize(iw,iw)
01363 c
01364 else if((idev.eq.15))then
01365 c
01366 c SunCore ideosyncrasies:
01367 c
01368 c setlinewidth(x) --> single for 0.0 to 0.3
01369 c double for 0.4, 0.5
01370 c heavy for 0.6
01371 c heavier for 0.7
01372 c heavier still for 0.8, 0.9
01373 c ...
01374 c
01375 if (iwt.le.5) then
01376 ww = 0.1
01377 else if (iwt.le.15) then
01378 ww = 0.4 + 0.01*(iwt-5)
01379 else
01380 ww = 0.6 + 0.01*(iwt-15)
01381 end if
01382 call setlinewidth(ww)
01383 c
01384 else if(idev.eq.16)then
01385 c
01386 c PostScript.
01387 c
01388 call ps stroke
01389 write(42,'(f5.1,'' setlinewidth'')').1*iwt
01390 write(42,'(''2 setlinejoin 2 setlinecap'')')
01391 c
01392 c N.B. PS weight applies to SUBSEQUENT lines only.
01393 c
01394 else if (idev.eq.17) then
01395 jwt = max(0, nint(.1*iwt+.5))
01396 call mcdxlinew(jwt)
01397 end if
01398 c
01399 idevwt = iwt
01400 c
01401 return
01402 c
01403 c-----------------------------------------------------------------------
01404 c
01405 entry pen(ipenin)
01406 c ***************
01407 c Set pen characteristics ("color"). * PEN/COLOR *
01408 c ***************
01409 ipen = ipenin
01410 525 if(idev.eq.1)then
01411 write(60,500)5,char(modulo(ipen,64)+32)
01412 else if((idev.eq.5.or.idev.eq.6).and.ipen.ne.idevpen)then
01413 if(idevon.le.0)write(6,510)hpon
01414 write(6,530)max(0,min(8,ipen))
01415 530 format(' SP',i1,';')
01416 if(idevon.le.0)write(6,510)hpoff
01417 idevpen = ipen
01418 else if(idev.eq.13.or.idev.eq.14)then
01419 call output char(esc)
01420 write(chout,531)min(7,max(0,ipen))
01421 531 format('ML',i1)
01422 call type string(tekout,3)
01423 else if(idev.eq.15)then
01424 call setlineindex(ipen)
01425 call settextindex(ipen)
01426 c Note that ipen = 0 erases
01427 else if(idev.eq.16)then
01428 call ps color(ipen)
01429 c
01430 c N.B. PS pen color applies to SUBSEQUENT lines only.
01431 c
01432 else if (idev.eq.17) then
01433 c
01434 c For now, just wrap the colormap...
01435 c
01436 jpen = ipen/ncolor
01437 if (jpen.gt.0) ipen = ipen - ncolor*jpen
01438 call mcdxcolor(ipen)
01439 end if
01440 idevpen = ipen
01441 c
01442 return
01443 c
01444 entry color(icolor)
01445 c
01446 ipen = icolor
01447 go to 525
01448 c
01449 entry getcolor(jcolor)
01450 jcolor = idevpen
01451 return
01452 c
01453 c-----------------------------------------------------------------------
01454 c
01455 entry background(iback)
01456 c ****************
01457 c Set background color. * BACKGROUND *
01458 c ****************
01459 if (idev.eq.15) then
01460 call corebackg(iback)
01461 else if (idev.eq.17) then
01462 c
01463 c For now, just wrap the colormap...
01464 c
01465 jback = iback/ncolor
01466 if (jback.gt.0) iback = iback - ncolor*jback
01467 call mcdxbackg(iback)
01468 end if
01469 c
01470 ibackgcolor = iback
01471 c
01472 return
01473 c
01474 c-----------------------------------------------------------------------
01475 c
01476 entry devon
01477 c ***********
01478 c Explicitly initiate output to graphics device. * DEVON *
01479 c ***********
01480 if (idevon.ne.1) then
01481 if(itek.eq.1)then
01482 if(ivers.eq.0)then
01483 if (idev.eq.9.or.idev.eq.10) then
01484 c
01485 c Xterm escape sequences:
01486 c
01487 call output char(esc)
01488 call output char('[')
01489 call output char('?')
01490 call output char('3')
01491 call output char('8')
01492 call output char('h')
01493 else
01494 call output char(esc)
01495 call output char(';')
01496 write(6,*)
01497 end if
01498 end if
01499 call output char(gs)
01500 else if(idev.eq.5.or.idev.eq.6)then
01501 write(6,510)hpon
01502 end if
01503 idevon = 1
01504 end if
01505 return
01506 c
01507 c-----------------------------------------------------------------------
01508 c
01509 entry devoff
01510 c ************
01511 c Explicitly terminate output to graphics device. * DEVOFF *
01512 c ************
01513 iquit = 0
01514 c
01515 200 if (idevon.ne.0) then
01516 c
01517 if (itek.eq.1) then
01518 if (ivers.eq.0) then
01519 if (idev.eq.9.or.idev.eq.10) then
01520 c
01521 c Xterm escape sequences:
01522 c
01523 c Flush the buffer (100 may be overkill, but...).
01524 c
01525 call plot(-10.,-10.,3)
01526 do 210 i=1,100
01527 call plot(-10.,-10.,2)
01528 210 continue
01529 c
01530 call output char(esc)
01531 call output char(char(3))
01532 c
01533 else
01534 call plot(-10.,-10.,3)
01535 call plot(-10.,-10.,2)
01536 end if
01537 end if
01538 call output char(esc)
01539 call output char('2')
01540 c
01541 else if(idev.eq.5.or.idev.eq.6)then
01542 write(6,510)hpoff
01543 npo = 3
01544 end if
01545 c
01546 idevon = 0
01547 c
01548 end if
01549 c
01550 if (iquit.eq.1) then
01551 c
01552 c Complete MCQUIT operations.
01553 c
01554 init = 0
01555 idev = 0
01556 device = ' '
01557 iin = 0
01558 end if
01559 c
01560 return
01561 c
01562 c-----------------------------------------------------------------------
01563 c
01564 entry graphin(r,s)
01565 c
01566 c Return the location of the graphics pointer relative *************
01567 c to the current origin (implemented for Tektronix, X, * GRAPHIN *
01568 c and SUN options only). *************
01569 c
01570 if (.not.gfxin()) return
01571 c
01572 if(idev.eq.15)then
01573 kount = 0
01574 400 call awtbuttongetloc2(0,1,ibutton,xx,yy)
01575 if(ibutton.eq.0)then
01576 kount = kount+1
01577 if(kount.lt.12000)then
01578 call uwait(5000)
01579 go to 400
01580 end if
01581 write(6,*)'timed out...'
01582 xx = 0.
01583 yy = 0.
01584 end if
01585 c
01586 r = xsize*xx-ro
01587 s = xsize*yy-so
01588 c Yes, this SHOULD be xsize!!
01589 c
01590 iposn = 1000*xx
01591 jposn = 1000*yy
01592 return
01593 else if (idev.eq.17) then
01594 call mcdxgin(r,s)
01595 iposn = nxpix*r/xsize
01596 jposn = nypix*s/ysize
01597 r = r - ro
01598 s = s - so
01599 return
01600 end if
01601 c
01602 if (itek.eq.0) return
01603 c
01604 c The rest is for Tektronix mode(s).
01605 c
01606 if (idevon.eq.0) then
01607 if (idev.eq.9.or.idev.eq.10) then
01608 call output char(esc)
01609 call output char('[')
01610 call output char('?')
01611 call output char('3')
01612 call output char('8')
01613 call output char('h')
01614 else
01615 call output char(gs)
01616 end if
01617 idevon = 1
01618 end if
01619 c
01620 c enter gin mode...
01621 c
01622 call output char(esc)
01623 call output char(ctrlz)
01624 c
01625 c ...read the pointer address, preceded by a lead-in character...
01626 c
01627 if(nxpix.gt.1023)then
01628 kmax = 6
01629 else
01630 kmax = 5
01631 end if
01632 c do 95 k=1,kmax
01633 do 95 k=1,kmax
01634 call input char(tekin(k))
01635 if((tekin(k).eq.lf.or.tekin(k).eq.cr).and.k.gt.1)go to 96
01636 95 continue
01637 k = kmax+1
01638 96 kmax = k-1
01639 c
01640 c ...and exit gin mode.
01641 c
01642 if (idev.ne.9.and.idev.ne.10) then
01643 call output char(cr)
01644 else
01645 c
01646 c Xterm version -- leave GFX mode:
01647 c
01648 call output char(esc)
01649 call output char(char(3))
01650 idevon = 0
01651 end if
01652 c
01653 c Each use of graphin causes the tektronix to go out of graph
01654 c mode momentarily, so we must reposition the pointer:
01655 c
01656 call plot(rl,sl,3)
01657 c
01658 c This will also undo VersaTerm "inverted" mode, so reset, if necessary:
01659 c
01660 if(inv.eq.1)then
01661 call output char(esc)
01662 if(idev.eq.14)then
01663 chout = 'ML0'
01664 call type string(tekout,3)
01665 else
01666 call output char(del)
01667 end if
01668 end if
01669 c
01670 c Now decode the address from tekin(2),...,tekin(kmax).
01671 c note that the input string is encoded differently from the
01672 c corresponding output in plot or pixel.
01673 c
01674 i32 = 32
01675 c (force integer*4 arithmetic below)
01676 c
01677 if(kmax.eq.5)then
01678 i = (ichar(tekin(2))-32)*i32 + (ichar(tekin(3))-32)
01679 j = (ichar(tekin(4))-32)*i32 + (ichar(tekin(5))-32)
01680 if(nxpix.gt.1023)then
01681 i = 4*i
01682 j = 4*j
01683 end if
01684 else
01685 c
01686 c This possibility might not actually be legal. It is
01687 c not yet tested.
01688 c
01689 ii = ichar(tekin(5))-32
01690 jj = ii/4
01691 ii = ii-4*jj
01692 i = 4*((ichar(tekin(2))-32)*i32 + (ichar(tekin(3))-32)) + ii
01693 j = 4*((ichar(tekin(4))-32)*i32 + (ichar(tekin(6))-32)) + jj
01694 end if
01695 r = (i-nx0)/xfac-ro
01696 s = (j-ny0)/yfac-so
01697 iposn = i
01698 jposn = j
01699 leadin = chtekin(1:1)
01700 if(idevon.le.0)then
01701 call output char(esc)
01702 call output char('2')
01703 end if
01704 return
01705 c
01706 c-----------------------------------------------------------------------
01707 c
01708 entry erase(rmin,rmax,smin,smax)
01709 c ***********
01710 c Clear a rectangular region of the display (for * ERASE *
01711 c SUN, X, PostScript and "Versaterm" options only) ***********
01712 c
01713 if(idev.eq.15.or.idev.eq.16.or.idev.eq.17)then
01714 xbox(1) = rmin
01715 xbox(2) = rmax
01716 xbox(3) = rmax
01717 xbox(4) = rmin
01718 ybox(1) = smin
01719 ybox(2) = smin
01720 ybox(3) = smax
01721 ybox(4) = smax
01722 call polyerase(xbox,ybox,4)
01723 end if
01724 c
01725 if(ivers.eq.0)return
01726 c
01727 if(idevon.le.0)then
01728 call output char(gs)
01729 idevon = 1
01730 end if
01731 c
01732 if(1.eq.0.and.idev.ge.8.and.idev.le.12)then
01733 c
01734 c if pensize doesn't work, use this...
01735 c
01736 i1 = (rmin+ro)*xfac+nx0
01737 i2 = (rmax+ro)*xfac+nx0
01738 j1 = (smin+so)*yfac+ny0
01739 j2 = (smax+so)*yfac+ny0
01740 call output char(esc)
01741 call output char(del)
01742 if(i2-i1.gt.j2-j1)then
01743 do 11001 j=j1,j2
01744 call pixel(i1,j,3)
01745 call pixel(i2,j,2)
01746 11001 continue
01747 else
01748 do 11002 i=i1,i2
01749 call pixel(i,j1,3)
01750 call pixel(i,j2,2)
01751 11002 continue
01752 end if
01753 call output char(cr)
01754 return
01755 else if(idev.lt.13)then
01756 i = 0
01757 j = (smax-smin)*yfac+1
01758 call pensize(i,j)
01759 c
01760 c turn on erase mode:
01761 c
01762 call output char(esc)
01763 call output char(del)
01764 c
01765 c draw the line:
01766 c
01767 call plot(rmin,smax,3)
01768 call plot(rmax,smax,2)
01769 c
01770 c reset:
01771 c
01772 call output char(cr)
01773 else if(idev.eq.14)then
01774 call output char(esc)
01775 chout = 'MP0'
01776 call type string(tekout,3)
01777 call output char(esc)
01778 chout = 'LP'
01779 call type string(tekout,2)
01780 call xyencode(rmin,smin,vec)
01781 call type string(vec,5)
01782 call type string(tekout,2)
01783 call plot(rmin,smax,2)
01784 call plot(rmax,smax,2)
01785 call plot(rmax,smin,2)
01786 call plot(rmin,smin,2)
01787 call output char(esc)
01788 chout = 'LE'
01789 call type string(tekout,2)
01790 end if
01791 return
01792 c
01793 c-----------------------------------------------------------------------
01794 c
01795 entry clear
01796 c ***********
01797 c clear entire screen, if any,... * CLEAR *
01798 c ***********
01799 if (idev.eq.1) then
01800 write(60,500)6
01801 else if (idev.eq.15) then
01802 call plframe
01803 else if (idev.eq.16) then
01804 c
01805 c Old version:
01806 c
01807 c write(42,'(''erasepage'')')
01808 c
01809 c New version (saves unnecessary output to the printer):
01810 c Close the output file, and copy it to a new file, omitting
01811 c all "plot" commands.
01812 c
01813 write(42,'(/''%Re-writing...''/)')
01814 call ps rewrite
01815 ixleft = 10000
01816 iybot = 10000
01817 ixright = 0
01818 iytop = 0
01819 c
01820 nstroke = 0
01821 nstrpage = 0
01822 nstroketot = 0
01823 else if (idev.eq.17) then
01824 call mcdxclear
01825 else if (itek.eq.1) then
01826 if(idev.eq.12.or.idev.eq.14)then
01827 call output char(esc)
01828 call output char(ff)
01829 else
01830 call type string(tekc,4)
01831 end if
01832 if(ivers.eq.0)then
01833 call plot(-10.,10.,3)
01834 call plot(-10.,10.,2)
01835 end if
01836 end if
01837 return
01838 c
01839 c-----------------------------------------------------------------------
01840 c
01841 entry invert
01842 c ************
01843 c Toggle between draw and undraw modes (SUN, * INVERT *
01844 c PostScript, X and Versaterm modes only). ************
01845 c
01846 if (idev.eq.15.or.idev.eq.16.or.idev.eq.17) then
01847 if(idevpen.gt.0)then
01848 ipensto = idevpen
01849 idevpen = 0
01850 else
01851 idevpen = ipensto
01852 end if
01853 c
01854 if(idev.eq.15)then
01855 call setlineindex(idevpen)
01856 else if (idev.eq.16) then
01857 call ps color(idevpen)
01858 else if (idev.eq.17) then
01859 call mcdxcolor(idevpen)
01860 end if
01861 return
01862 end if
01863 c
01864 if (idev.ne.7.and.idev.ne.8.and.idev.ne.10
01865 & .and.idev.ne.12.and.idev.ne.14) return
01866 c
01867 if(idevon.le.0)then
01868 call output char(gs)
01869 idevon = 1
01870 end if
01871 if(inv.eq.0)then
01872 call output char(esc)
01873 if(idev.eq.14)then
01874 chout = 'ML0'
01875 call type string(tekout,3)
01876 else
01877 call output char(del)
01878 end if
01879 inv = 1
01880 else
01881 if(idev.eq.14)then
01882 call output char(esc)
01883 chout = 'ML1'
01884 call type string(tekout,3)
01885 else
01886 call output char(cr)
01887 end if
01888 inv = 0
01889 end if
01890 c
01891 c Note that we have probably lost track of the graphics pointer
01892 c through this action.
01893 c
01894 return
01895 c
01896 c-----------------------------------------------------------------------
01897 c
01898 entry point(r,s)
01899 c ***********
01900 c Plot a single point. * POINT *
01901 c ***********
01902 if(idev.eq.16)then
01903 rr = nx0+xfac*(r+ro)
01904 ss = ny0+yfac*(s+so)
01905 if(ibounds.ne.0)then
01906 rr = max(0.,min(ps rmax,rr))
01907 ss = max(0.,min(ps smax,ss))
01908 end if
01909 write(42,'(f7.3,f8.3,'' p%'')')rr,ss
01910 if(nstroke.ge.NSMAX/2)then
01911 call ps stroke
01912 write(42,'(f7.3,f8.3,'' m%'')')rr,ss
01913 end if
01914 nstroke = nstroke+1
01915 nstrpage = nstrpage+1
01916 nstroketot = nstroketot+1
01917 else if (idev.eq.17) then
01918 call mcdxpoint(r+ro,s+so)
01919 else
01920 call plot(r,s,3)
01921 call plot(r,s,2)
01922 end if
01923 c
01924 return
01925 c
01926 c-----------------------------------------------------------------------
01927 c
01928 entry polydraw(rpoly,spoly,npoly)
01929 c **************
01930 c Draw a regular polygon. * POLYDRAW *
01931 c **************
01932 call plot(rpoly(npoly),spoly(npoly),3)
01933 do 10 i = 1,npoly
01934 call plot(rpoly(i),spoly(i),2)
01935 10 continue
01936 c
01937 return
01938 c
01939 c-----------------------------------------------------------------------
01940 c
01941 entry polyfill(rpoly,spoly,npoly)
01942 c **************
01943 c Draw a filled regular polygon. * POLYFILL *
01944 c **************
01945 if((idev.ne.15.and.idev.ne.16.and.idev.ne.17)
01946 & .or.index.lt.0) return
01947 c
01948 if (idev.eq.15.or.idev.eq.17) then
01949 c
01950 c SunCore/X want absolute coordinates.
01951 c
01952 do 110 i=1,npoly
01953 rpoly(i) = rpoly(i) + ro
01954 spoly(i) = spoly(i) + so
01955 110 continue
01956 end if
01957 c
01958 if(idev.eq.15)then
01959 c
01960 call polygonabs2(rpoly,spoly,npoly)
01961 c
01962 else if (idev.eq.16) then
01963 c
01964 call ps color(index)
01965 c
01966 call plot(rpoly(npoly),spoly(npoly),3)
01967 do 120 i=1,npoly
01968 call plot(rpoly(i),spoly(i),2)
01969 120 continue
01970 write(42,'(''fill'')')
01971 call ps color(ipen)
01972 c
01973 else if (idev.eq.17) then
01974 c
01975 call mcdxpolyf(rpoly,spoly,npoly,index)
01976 c
01977 end if
01978 c
01979 if (idev.eq.15.or.idev.eq.17) then
01980 do 130 i=1,npoly
01981 rpoly(i) = rpoly(i) - ro
01982 spoly(i) = spoly(i) - so
01983 130 continue
01984 end if
01985 c
01986 return
01987 c
01988 c-----------------------------------------------------------------------
01989 c
01990 entry bounded
01991 entry bounds
01992 c *************
01993 c Enforce/don't enforce xsize x ysize bounds * BOUNDED *
01994 c on (currently, only PostScript) output. *************
01995 c
01996 ibounds = 1
01997 return
01998 c
01999 entry unbounded
02000 entry nobounds
02001 ibounds = 0
02002 return
02003 c
02004 c-----------------------------------------------------------------------
02005 c
02006 entry eop
02007 entry newp
02008 entry newplot
02009 entry nextplot
02010 entry newpage
02011 c ***************
02012 c End plot, prepare for new one (flush buffer, * EOP, etc. *
02013 c clear screen, etc.),... ***************
02014 c
02015 if(idev.eq.1)then
02016 write(60,500)7
02017 else if(idev.eq.2)then
02018 call frame
02019 else if(itek.eq.1)then
02020 call display text(
02021 & 'Enter <CR> to clear screen. ',40)
02022 read(5,350)idummy
02023 350 format(a1)
02024 if(idev.ne.13.and.idev.ne.14)then
02025 call type string(tekc,4)
02026 else
02027 call output char(esc)
02028 call output char(ff)
02029 end if
02030 else if(idev.eq.5.or.idev.eq.6)then
02031 if(idevon.le.0)write(6,510)hpon
02032 write(6,510)hpc
02033 if(idevon.le.0)write(6,510)hpoff
02034 else if(idev.eq.15)then
02035 call sunwait
02036 call plframe
02037 else if(idev.eq.16)then
02038 call ps page(1)
02039 else if (idev.eq.17) then
02040 write(6,'(''Click right-hand mouse button'
02041 $ ' in window to exit X.'')')
02042 call mcdxidle
02043 call mcdxreset
02044 end if
02045 go to 200
02046 c
02047 c-----------------------------------------------------------------------
02048 c
02049 entry set_win(iwin, iret)
02050 c ***************
02051 c Choose output window. * SET_WIN *
02052 c ***************
02053 c
02054 if (idev.eq.17) then
02055 iret = mcdxsetwin(iwin)
02056 c
02057 c Return status is -1 on error.
02058 c
02059 end if
02060 c
02061 return
02062 c
02063 c-----------------------------------------------------------------------
02064 c
02065 entry kill_win(iwin)
02066 c ***************
02067 c Kill output window. * KILL_WIN *
02068 c ***************
02069 c
02070 if (idev.eq.17) then
02071 call mcdxkillwin(iwin)
02072 if (mcdxnopen().le.0) then
02073 c
02074 c No windows left!
02075 c
02076 idev = 0
02077 device = ' '
02078 iin = 0
02079 idevon = 0
02080 end if
02081 end if
02082 c
02083 return
02084 c
02085 c-----------------------------------------------------------------------
02086 c
02087 entry iconify_win(iwin)
02088 c ***************
02089 c Iconify an output X window. * ICONIFY_WIN *
02090 c ***************
02091 c
02092 call mcdxiconifywin(iwin)
02093 c
02094 return
02095 c
02096 c-----------------------------------------------------------------------
02097 c
02098 entry iconify_all
02099 c ***************
02100 c Iconify all output X windows. * ICONIFY_ALL *
02101 c ***************
02102 c
02103 call mcdxiconifyall()
02104 c
02105 return
02106 c
02107 c-----------------------------------------------------------------------
02108 c
02109 entry set_colormap(filename,ier)
02110 c ***************
02111 c Load a colormap from a file. * SET_COLORMAP*
02112 c ***************
02113 c
02114 nf = 0
02115 do i=len(filename),1,-1
02116 if (nf.eq.0.and.filename(i:i).gt.' ') nf = i
02117 end do
02118 c
02119 c HP fortran doesn't understand '\0'...
02120 c
02121 call mcdxsetwincolormap(filename(1:nf)
02122 c
02123 return
02124 c
02125 c-----------------------------------------------------------------------
02126 c
02127 entry win_read_line(string)
02128 c *****************
02129 c Read a line of text from the (X) window system. * WIN_READ_LINE *
02130 c *****************
02131 c
02132 if (mcdxnopen().gt.0) then
02133 call mcdxread_line(string)
02134 end if
02135 c
02136 return
02137 c
02138 c-----------------------------------------------------------------------
02139 c
02140 entry routine id(id string)
02141 c ****************
02142 c Identify key routines. * ROUTINE ID *
02143 c ****************
02144 c
02145 if (idev.eq.16) then
02146 do 450 i=len(id string),1,-1
02147 if (id string(i:i).gt.' ') go to 455
02148 450 continue
02149 return
02150 455 write(42,'(''%%% Routine '',a,'':'')')id string(1:i)
02151 end if
02152 c
02153 return
02154 c
02155 c-----------------------------------------------------------------------
02156 c
02157 entry mcquit
02158 iquit = 0
02159 go to 1000
02160 c
02161 entry mcquit1
02162 iquit = 1
02163 c ************
02164 c Terminate graphics session. * MCQUIT *
02165 c ************
02166 1000 if (isun.gt.0) then
02167 write(6,'(''Enter <CR> to terminate graphics.'')')
02168 call plstop
02169 isun = 0
02170 end if
02171 c
02172 c NOTE: The system call in psquit apparently requires that SunCore
02173 c graphics be terminated before attempting to print any PostScript file.
02174 c
02175 call psquit
02176 c
02177 c Call to psquit does nothing if no PS device is open.
02178 c
02179 if (mcdxnopen().gt.0) then
02180 if (iquit.eq.1) then
02181 write(6,
02182 $ '(''Click right-hand mouse button in current'
02183 $ ' window to exit X.'')')
02184 call mcdxidle
02185 end if
02186 end if
02187 c
02188 call mcdxquit
02189 c
02190 c Remaining termination is done by devoff (label 200).
02191 c
02192 iquit = 1
02193 go to 200
02194 c
02195 end
02196
02197
02198 logical function gfxin()
02199 save
02200 c ***********
02201 c Return TRUE iff graphin will work. * GFXIN *
02202 c ***********
02203 character*80 device
02204 common /plot device/ device,aspect,idev
02205 common /dev details/ itek,ivers
02206 c
02207 if (idev.eq.15.or.idev.eq.17.or.itek.eq.1
02208 c & .or.(itek.eq.1.and.idev.ne.9.and.idev.ne.10)
02209 & ) then
02210 gfxin = .true.
02211 else
02212 gfxin = .false.
02213 end if
02214 c
02215 end
02216
02217
02218 integer function num_win(id)
02219 save
02220 c ***********
02221 c Return the number of open windows associated with id. * NUM_WIN *
02222 c ***********
02223 character*80 device
02224 common /plot device/ device,aspect,idev
02225 c
02226 logical ps_open
02227 external mcdxnopen !$pragma C (mcdxnopen)
02228 c
02229 num_win = 0
02230 if (id.gt.0) then
02231 c
02232 c PostScript and X can be open without being active.
02233 c
02234 if (id.eq.16) then
02235 if (ps_open()) num_win = 1
02236 else if (id.eq.17) then
02237 num_win = mcdxnopen()
02238 else
02239 if (id.eq.idev) num_win = 1
02240 end if
02241 end if
02242 c
02243 end
02244
02245
02246 integer function curr_win()
02247 save
02248 c ************
02249 c Return the current output window. * CURR_WIN *
02250 c ************
02251 character*80 device
02252 common /plot device/ device,aspect,idev
02253 c
02254 external mcdxcurrwin !$pragma C (mcdxcurrwin)
02255 c
02256 if (idev.le.0) then
02257 curr_win = -1
02258 else
02259 curr_win = 0
02260 if (idev.eq.17) curr_win = mcdxcurrwin()
02261 end if
02262 c
02263 end
02264
02265
02266 subroutine polyerase(r,s,n)
02267 save
02268 c
02269 c Erase the specified polygonal area.
02270 c
02271 external mcdxpolyf !$pragma C (mcdxpolyf)
02272 c
02273 dimension r(1),s(1)
02274 character*80 device
02275 common /plot device/ device,aspect,idev
02276 common /plot origin/ ro,so
02277 common /backgcolor/ ibackgcolor
02278 save /backgcolor/
02279 c
02280 if(idev.eq.15)then
02281 c
02282 c Switch to absolute coordinates:
02283 c
02284 do k=1,n
02285 r(k) = r(k) + ro
02286 s(k) = s(k) + so
02287 end do
02288 c
02289 call setfillindex(0)
02290 call polygonabs2(r,s,n)
02291 c
02292 do k=1,n
02293 r(k) = r(k) - ro
02294 s(k) = s(k) - so
02295 end do
02296 c
02297 else if(idev.eq.16)then
02298 c
02299 call ps stroke
02300 call plot(r(n),s(n),3)
02301 do i=1,n
02302 call plot(r(i),s(i),2)
02303 end do
02304 write(42,'(''1.0 setgray''/''fill''/f5.3,'' setgray'')')
02305 & ipen/256.
02306 call ps color(ipen)
02307 c
02308 else if (idev.eq.17) then
02309 c
02310 c Switch to absolute coordinates:
02311 c
02312 do k=1,n
02313 r(k) = r(k) + ro
02314 s(k) = s(k) + so
02315 end do
02316 c
02317 call mcdxpolyf(r,s,n,ibackgcolor)
02318 c
02319 do k=1,n
02320 r(k) = r(k) - ro
02321 s(k) = s(k) - so
02322 end do
02323 c
02324 end if
02325 c
02326 end
