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 c
00021 c *****************************************************************
00022 c * *
00023 c * GET DEVICE: Get/set graphics device characteristics. *
00024 c * *
00025 c *****************************************************************
00026 c
00027 subroutine get device
00028 save
00029 c
00030 character*80 device,opt
00031 common /plot sizes/ xsize,ysize
00032 c
00033 common /plot device/ device,aspect,idev
00034 common /forced/ opt
00035 c
00036 common /framesize/ nxpix,nx0,xfac,nypix,ny0,yfac
00037 common /ncar/ nxpix1,nypix1,nx01,ny01,xfac1,yfac1
00038 common /plain font/ wid
00039 common /dev status/ idevon,idevpen,idevwt
00040 common /dev details/ itek,ivers
00041 c
00042 common /hp plot/ ivdef
00043 character*1 hpinit1(34),hpinit2(34)
00044 c
00045 character*1 ctrl(0:31),
00046 & null,ctrla,tab,lf,ff,cr,ctrlx,ctrlz,esc,gs,del
00047 common /ctrlch/ ctrl,
00048 & null,ctrla,tab,lf,ff,cr,ctrlx,ctrlz,esc,gs,del
00049 c
00050 common /graphproc/ igp
00051 common /mcpak_colormap/ ncolor,red(0:255),green(0:255),
00052 & blue(0:255)
00053 c
00054 common /ps head flag/ iheadflag
00055 save /ps head flag/
00056 common /ps keep/ ikeepps,iprintps
00057 common /ps enforced/ ibounds,ps rmax,ps smax
00058 common /ps copies/ ncopies
00059 character*80 psfile,temp
00060 logical ps_open
00061 c
00062 common /sunscreen/ isun
00063 c
00064 external mcdxnopen !$pragma C (mcdxnopen)
00065 external mcdxinit !$pragma C (mcdxinit)
00066 external mcdxquit !$pragma C (mcdxquit)
00067 c
00068 common /x input/ interact
00069 common /xwin init/ no_new_xwin
00070 c
00071 data iheadflag/1/no_new_xwin/-1/
00072 c
00073 data hpinit1/' ','.','Y',' ','.','P','1',':',
00074 & ' ','.','T','1','0','0','0','0',';','1','0','0',
00075 & ';',';','1','0','0',';','2','0','0','0',':',
00076 & ' ','.','L'/
00077 data hpinit2/' ','.','@','9','0','0','0',';',':',
00078 & 'S','P','1',';','I','N',';','R','O','0','0',';',
00079 & 'I','P',';','C','S','0',';','C','V','1',
00080 & ' ','.','Z'/
00081 c
00082 do 10001 i=1,34
00083 if (hpinit1(i).eq.' ')hpinit1(i)=esc
00084 if (hpinit2(i).eq.' ')hpinit2(i)=esc
00085 10001 continue
00086 c
00087 ireaderror=0
00088 ienv = 0
00089 c
00090 10101 do 10201 nd=80,1,-1
00091 if (device(nd:nd).gt.' ')go to 10003
00092 10201 continue
00093 c
00094 c No device specified. See if the environment contains an
00095 c "MCD_DEVICE" setting.
00096 c
00097 if (ienv.eq.0) then
00098 call mygetenv('MCD_DEVICE', device)
00099 ienv = 1
00100 c write(6,'(a,a,a)')'env dev = "',device,'"'
00101 go to 10101
00102 end if
00103 ienv = 2
00104 c
00105 c Prompt for a device ID.
00106 c
00107 1 device=' '
00108 write(6,'(''Device: ''$)')
00109 read(5,'(a80)',end=2,err=2)device
00110 ienv = 0
00111 do 10002 nd=80,1,-1
00112 if (device(nd:nd).gt.' ')go to 10003
00113 10002 continue
00114 c
00115 2 if (ireaderror.gt.3) then
00116 write(6,*)'Too many errors!'
00117 stop
00118 end if
00119 c
00120 write(6,3)
00121 3 format(/' Options:'/
00122 & ' d: store vectors on disk (PLOT.DAT)'/
00123 & ' n: NCAR plotting package (not implemented)'/
00124 & ' t01: Tektronix 4010, 10x10'/
00125 & ' t02: Tektronix 4010, 10x7.6'/
00126 & ' t41: Tektronix 4014, 10x10 - XTERM'/
00127 & ' t, t42: Tektronix 4014, 10x7.6 - XTERM'/
00128 & ' t5: Tektronix 4105'/
00129 & ' h: HP plotter 7550a'/
00130 & ' ht ==> transparency'/
00131 & ' h1 ==> 10x10 display (10x7.7 otherwise)'/
00132 & ' hr ==> 90 degree rotation',
00133 & ' (--> 10x10 or 10x13.0)'/
00134 & ' v0: as t0, but for mac/versaterm'/
00135 & ' v, v4: as t4, but for versaterm-pro'/
00136 & ' v5: as t5, but for versaterm-pro'/
00137 & ' s: SUN window output'/
00138 & ' p: PostScript output'/
00139 & ' x: X window output (test version)'/
00140 & )
00141 c
00142 c Devices and associated IDs:
00143 c --------------------------
00144 c
00145 c d: 1
00146 c n: 2
00147 c t01: 3
00148 c t02: 4
00149 c ht: 5
00150 c hr: 5
00151 c h1: 6
00152 c v01: 7
00153 c v02: 8
00154 c t41: 9
00155 c t = t42: 10
00156 c v41: 11
00157 c v = v42: 12
00158 c t5: 13
00159 c v5: 14
00160 c s: 15
00161 c p: 16
00162 c x: 17
00163 c
00164 ireaderror=ireaderror+1
00165 go to 1
00166 c
00167 10003 if (ienv.eq.1) write(6,'(a)')'Adopted device = "'//
00168 & device(1:nd)//'" from the environment'
00169 nd=nd+1
00170 device(nd:nd)=' '
00171 c
00172 c ONLY CONVERT THE FIRST NONBLANK CHARACTER TO LOWERCASE!!!
00173 c
00174 4 do 5 i=1,nd
00175 if (device(i:i).ge.'A'.and.device(i:i).le.'Z')
00176 & device(i:i)=char(ichar(device(i:i))+32)
00177 if (device(i:i).gt.' ') go to 6
00178 5 continue
00179 c
00180 6 do 10 i=1,nd
00181 if (device(i:i).gt.' ')go to 15
00182 10 continue
00183 go to 2
00184 15 do j=i,nd
00185 device(j-i+1:j-i+1)=device(j:j)
00186 end do
00187 nd=nd-i+1
00188 c
00189 c------------------------------------------------------------------------
00190 c
00191 c The rest of this routine checks the device and sets the following
00192 c generally-used variables (as well as any device-specific ones):
00193 c
00194 c itek = 1 if we are a Tektronix
00195 c ivers = 1 if we are Versaterm
00196 c wid = nominal character width
00197 c aspect = device aspect ratio
00198 c ncolor = number of colors available
00199 c nxpix = number of pixels in the x direction
00200 c nypix = number of pixels in the y direction
00201 c nx0 = x offset of the plotting area
00202 c ny0 = y offset of the plotting area
00203 c idev = device ID
00204 c
00205 itek=0
00206 ivers=0
00207 wid=1.
00208 aspect=1.
00209 ncolor=2
00210 c
00211 if (device(1:1).eq.'d') then
00212 c
00213 c Generic data file (not used).
00214 c ----------------------------
00215 c
00216 idev=1
00217 open(60,file='PLOT.DAT',status='unknown',form='formatted')
00218 rewind 60
00219 nx0=0
00220 nxpix=262143
00221 c = 64**3 - 1
00222 ny0=nx0
00223 nypix=nxpix
00224 c
00225 else if (device(1:1).eq.'n') then
00226 c
00227 c NCAR graphics (not implemented now).
00228 c -----------------------------------
00229 c
00230 idev=2
00231 c
00232 c for centered output (e.g. to lca0):
00233 c
00234 nx0=384
00235 nxpix=32000
00236 c
00237 c for output going to lpa0, smaller by 0.877 and
00238 c shifted left:
00239 c
00240 c nxpix=28064
00241 c nx0=10
00242 c
00243 nypix=nxpix
00244 ny0=nx0
00245 wid=.86
00246 nxpix1=877
00247 nypix1=nxpix1
00248 nx01=12
00249 ny01=nx01
00250 c
00251 else if (device(1:1).eq.'t') then
00252 c
00253 c Tektronix options (slightly buggy?).
00254 c -----------------------------------
00255 c
00256 if (device(2:2).eq.'0') then
00257 c
00258 c 4010: 1024x781 pixels.
00259 c
00260 if (device(3:3).eq.'1') then
00261 c
00262 c Square output area.
00263 c
00264 idev=3
00265 nxpix=781
00266 else
00267 c
00268 c Rectangular output area.
00269 c
00270 idev=4
00271 nxpix=1023
00272 aspect=.7625
00273 end if
00274 c
00275 else if (device(2:2).eq.'4'.or.device(2:2).eq.' ') then
00276 c
00277 c 4010: 4096x3132 pixels.
00278 c
00279 if (device(3:3).eq.'1') then
00280 c
00281 c Square output area.
00282 c
00283 idev=9
00284 nxpix=3132
00285 else
00286 c
00287 c Rectangular output area.
00288 c
00289 idev=10
00290 nxpix=4095
00291 aspect=.764
00292 end if
00293 c
00294 else if (device(2:2).eq.'5') then
00295 c
00296 c Tektronix 4105.
00297 c --------------
00298 c
00299 idev=13
00300 nxpix=4095
00301 else
00302 go to 2
00303 end if
00304 c
00305 itek=1
00306 nx0=0
00307 ny0=0
00308 nypix=nxpix*aspect
00309 c
00310 else if (device(1:1).eq.'h') then
00311 c
00312 c HP plotter.
00313 c ----------
00314 c
00315 i1=index(device(1:nd),'1')
00316 if (i1.gt.0)i1=1
00317 i2=1-i1
00318 it=index(device(1:nd),'t')
00319 if (it.gt.0)it=1
00320 ir=index(device(1:nd),'r')
00321 if (ir.gt.0)ir=1
00322 nx0=0
00323 ny0=0
00324 idev=5+i1
00325 if (ir.eq.0) then
00326 if (i1.eq.1) then
00327 nxpix=7840
00328 else
00329 nxpix=10170
00330 aspect=.7709
00331 end if
00332 nypix=7840
00333 hpinit2(19)='0'
00334 else
00335 if (i1.eq.1) then
00336 nypix=7840
00337 else
00338 nypix=10170
00339 aspect=1./.7709
00340 end if
00341 nxpix=7840
00342 hpinit2(19)='9'
00343 end if
00344 wid=.9
00345 write(6,'(1x,40a1)')hpinit1
00346 read(5,*)idummy
00347 idevpen=1
00348 hpinit2(12)='1'
00349 write(6,'(1x,40a1)')hpinit2
00350 if (it.eq.1)ivdef=1
00351 c
00352 else if (device(1:1).eq.'v') then
00353 c
00354 c Versaterm-PRO Tektronix emulation (buggy with latest VT release!).
00355 c -----------------------------------------------------------------
00356 c
00357 if (device(2:2).eq.'0') then
00358 c
00359 c Versaterm/Mac Tek 4010 emulation apparently allows pixel
00360 c addresses from 0 to 1023 in both x and y, but maps any
00361 c y-values above 781 onto 781! The actual output region is
00362 c a 17.3 cm by 10.1 cm screen.
00363 c (Similarly for versaterm-pro in 4014 mode with y > 3132.)
00364 c
00365 c For versaterm, only bother with 4010 emulation.
00366 c
00367 if (device(3:3).eq.'1') then
00368 c
00369 c Square output area.
00370 c
00371 idev=7
00372 nxpix=593
00373 nypix=781
00374 else
00375 c
00376 c Rectangular output area.
00377 c
00378 idev=8
00379 nxpix=1023
00380 nypix=781
00381 aspect=.58
00382 end if
00383 c
00384 else if (device(2:2).eq.'4'.or.device(2:2).eq.' ') then
00385 c
00386 c Tektronix 4014 emulation.
00387 c ------------------------
00388 c
00389 if (device(3:3).eq.'1') then
00390 c
00391 c Square output area.
00392 c
00393 idev=11
00394 nxpix=3132
00395 else
00396 c
00397 c Rectangular output area.
00398 c
00399 idev=12
00400 nxpix=4095
00401 aspect=.7648
00402 end if
00403 nypix=nxpix*aspect
00404 c
00405 else if (device(2:2).eq.'5') then
00406 c
00407 c Tektronix 4105 emulation.
00408 c ------------------------
00409 c
00410 idev=14
00411 nxpix=4095
00412 nypix=4095
00413 else
00414 go to 2
00415 end if
00416 c
00417 nx0=0
00418 ny0=0
00419 itek=1
00420 ivers=1
00421 c
00422 else if (device(1:1).eq.'s') then
00423 c
00424 c SunCore (under Sunview) -- now obsolete and no longer supported.
00425 c ---------------------------------------------------------------
00426 c
00427 c SunCore will not coexist peacefully with X or PostScript!
00428 c
00429 if (idev.eq.16) call psquit(2)
00430 if (idev.eq.17) call mcdxquit
00431 c
00432 if (isun.ne.0) then
00433 write(6,'(''Enter <CR> to delete window'',
00434 & '' and reinitialize graphics.'')')
00435 call plstop
00436 end if
00437 c
00438 if (nd.eq.1) then
00439 nd=2
00440 device(2:2)=' '
00441 end if
00442 c
00443 c Most Suncore initialization is done in plinit, which determines
00444 c the type of frame buffer we have, and the size of the color
00445 c map, opens a window and initializes the internals of the Core
00446 c sraphics package. Note that the interpretation of the input
00447 c command string is done by plinit, too.
00448 c
00449 call plinit('s -b 255 -a 1. -s .5 '
00450 &
00451 & aspect,icolor,igp,ncolor,ierr)
00452 if (ierr.ne.0) go to 2
00453 c
00454 idev=15
00455 isun=1
00456 c
00457 wid=.85
00458 idevwt = 1
00459 idevpen = 1
00460 c
00461 else if (device(1:1).eq.'p') then
00462 c
00463 c PostScript output.
00464 c -----------------
00465 c
00466 c Only allow one open PostScript file. Note that opening
00467 c PostScript will not terminate any X windoes.
00468 c
00469 c SunCore will not coexist peacefully with X or PostScript!
00470 c
00471 if (idev.eq.15) then
00472 call plstop
00473 isun = 0
00474 end if
00475 c
00476 c If we already have an open PostScript file, append to it
00477 c (and set graphics parameters from stored values). If we
00478 c specify a file name that differs from the previous name,
00479 c close the current file and open a new one.
00480 c
00481 if (ps_open()) then
00482 call ps_filename(device(1:nd)
00483 if (temp(1:1).gt.' '
00484 $ .and.temp(1:nt).ne.psfile(1:npsf)) then
00485 c
00486 c A new file name was explicitly specified, and it is
00487 c not the same as the current one. Close out the current
00488 c file and get ready to open the new one.
00489 c
00490 call psquit(2)
00491 c
00492 end if
00493 end if
00494 c
00495 c Decipher options from command line if necessary
00496 c -----------------------------------------------
00497 c
00498 if (.not.ps_open())
00499 $ call ps_parse(device(1:nd)
00500 $ ikeepps,iprintps,iheadflag,ncopies,
00501 $ psfile,npsf,iorient,isparc,psaspect)
00502 c
00503 c Offset of origin:
00504 c
00505 c ***** Beware of magic numbers! *****
00506 c
00507 nx0=22
00508 ny0=nx0
00509 aspect = psaspect
00510 c
00511 if (iorient.eq.1) then
00512 nxpix = 570
00513 if (iaspect.gt.0) then
00514 nypix = aspect*nxpix
00515 else
00516 nypix = nxpix
00517 aspect = 1.
00518 end if
00519 else
00520 nxpix = 750
00521 if (iaspect.gt.0) then
00522 nypix = aspect*nxpix
00523 else
00524 nypix = 510
00525 end if
00526 aspect = nypix/float(nxpix)
00527 end if
00528 c
00529 ncolor=256
00530 psrmax=nx0+nxpix
00531 pssmax=ny0+nypix
00532 ibounds=1
00533 c
00534 c Attempt to guess a "standard" character width:
00535 c
00536 wid=.75
00537 c
00538 c NOTE change to defaults (overwrite previous PS settings):
00539 c Note also modification to ps color so color 1 is black in greyscale.
00540 c
00541 idevpen=1
00542 idevwt=5
00543 c
00544 c Note that we do NOT append to an existing file if we open
00545 c it with psinit!
00546 c
00547 idev = 16
00548 if (.not.ps_open())
00549 $ call psinit(psfile(1:npsf),iorient,isparc)
00550 c
00551 else if (device(1:1).eq.'x') then
00552 c
00553 c X-windows.
00554 c ---------
00555 c
00556 c SunCore will not coexist peacefully with X or PostScript!
00557 c
00558 if (idev.eq.15) then
00559 call plstop
00560 isun = 0
00561 end if
00562 c
00563 if (mcdxnopen().le.0.or.no_new_xwin.lt.0) then
00564 c
00565 c Open a new X window.
00566 c
00567 c Non-interactive flag for use with scripts.
00568 c
00569 interact = 1
00570 if (index(device(1:nd)
00571 & .or. index(device(1:nd)
00572 & interact = 0
00573 c
00574 xaspect = aspect
00575 call getaspect(device(1:nd)
00576 call mcdxinit(xaspect,nxpix,nypix,ncolor,ierr)
00577 if (ierr.gt.1) go to 2
00578 end if
00579 c
00580 c (Don't bother with pixels...)
00581 c
00582 aspect = xaspect
00583 idev = 17
00584 c
00585 c Defaults:
00586 c
00587 c background color = black (1)
00588 c foreground color = white (0)
00589 c pen width = 0
00590 c
00591 c NOTE: These may overwrite current X settings with defaults.
00592 c
00593 call background(0)
00594 idevpen = 1
00595 idevwt = 1
00596 wid=1.
00597 c
00598 else
00599 go to 2
00600 end if
00601 c
00602 end
00603
00604
00605 subroutine getaspect(string,iaspect,aspect)
00606 save
00607 character*(*) string
00608 c
00609 c Return the location and value of the aspect ratio in the input
00610 c string. Only the first "-a" with a legal number following counts.
00611 c
00612 iaspect = index(string,'-a')
00613 if (iaspect.le.0) iaspect = index(string,'-A')
00614 c
00615 if (iaspect.gt.0) then
00616 c
00617 c Locate and read the aspect ratio from the input string.
00618 c
00619 ibl = 1
00620 do 10 i=iaspect+2,len(string)
00621 if (string(i:i).le.' ') then
00622 if (ibl.eq.0) then
00623 if (index(string(iaspect+2:i),'.').gt.0) then
00624 read(string(iaspect+2:i),'(f20.10)',
00625 & iostat=ii)aa
00626 else
00627 read(string(iaspect+2:i),'(i20)',
00628 & iostat=ii)ia
00629 aa = ia
00630 end if
00631 if (ii.eq.0) then
00632 aspect = aa
00633 return
00634 end if
00635 end if
00636 else
00637 ibl = 0
00638 end if
00639 10 continue
00640 end if
00641 c
00642 end
00643
00644
00645 subroutine ps_parse(dev,nd,ikeepps,iprintps,iheadflag,ncopies,
00646 $ psfile,npsf,iorient,isparc,aspect)
00647 c
00648 c Read PostScript parameters from the "device" line.
00649 c
00650 character*(*) dev,psfile
00651 c
00652 c (1) Print/store:
00653 c
00654 ikeepps=0
00655 iprintps=1
00656 c
00657 if (index(dev,'-k').gt.0.or.index(dev,'-K').gt.0) ikeepps=1
00658 if (index(dev,'-n').gt.0.or.index(dev,'-N').gt.0) iprintps=0
00659 c
00660 if (iprintps.eq.0) ikeepps=1
00661 if (ikeepps.eq.0) iprintps=1
00662 c
00663 c (2) Suppress standard header line:
00664 c
00665 if (index(dev,'-h').gt.0.or.index(dev,'-H').gt.0) iheadflag=0
00666 c
00667 c (3) Specify # of copies:
00668 c
00669 ic=index(dev,'-c')
00670 if (ic.le.0) ic=index(dev,'-C')
00671 ncopies=1
00672 if (ic.gt.0.and.nd.gt.ic+2) then
00673 inum=0
00674 do 1600 ii=ic+3,nd
00675 if (dev(ii:ii).lt.'0'.or.dev(ii:ii).gt.'9') then
00676 if (inum.ne.0) then
00677 c
00678 c NOTE assumption of a trailing blank here!
00679 c
00680 j=ii-1
00681 if (ii.eq.nd) j=ii
00682 read(dev(inum:j),*,err=1610,end=1610)
00683 & ncopies
00684 go to 1610
00685 end if
00686 else
00687 if (inum.eq.0) inum=ii
00688 end if
00689 1600 continue
00690 end if
00691 c
00692 c (4) PostScript file name:
00693 c
00694 1610 if=index(dev,'-f')
00695 if (if.eq.0) if=index(dev,'-F')
00696 psfile=' '
00697 npsf=1
00698 if (if.gt.0) then
00699 inbl=0
00700 do 1650 ii=if+3,nd
00701 if (inbl.eq.0.and.dev(ii:ii).gt.' ') inbl=ii
00702 if (inbl.gt.0.and.dev(ii:ii).eq.' ') go to 1660
00703 1650 continue
00704 ii=nd+1
00705 1660 if (inbl.gt.0) then
00706 npsf=ii-inbl
00707 psfile(1:npsf)=dev(inbl:ii-1)
00708 ikeepps=1
00709 iprintps=0
00710 end if
00711 end if
00712 c
00713 c (5) Landscape mode?
00714 c
00715 iorient = 1
00716 if (index(dev,'-l').gt.0 .or. index(dev,'-L').gt.0) iorient = 2
00717 c
00718 c (6) SPARCprinter point-plotting bug fix:
00719 c
00720 isparc = 0
00721 if (index(dev,'-S').gt.0) isparc = 1
00722 c
00723 c (7) Force the output aspect ratio:
00724 c
00725 call getaspect(dev,iaspect,aspect)
00726 c
00727 end
00728
00729
00730 subroutine ps_filename(dev,nd,psfile,npsf)
00731 c
00732 c Attempt to read a PostScript file name from the "device" line.
00733 c
00734 character*(*) dev,psfile
00735 c
00736 psfile=' '
00737 npsf=1
00738 c
00739 if=index(dev,'-f')
00740 if (if.eq.0) if=index(dev,'-F')
00741 c
00742 if (if.gt.0) then
00743 inbl=0
00744 do ii=if+3,nd
00745 if (inbl.eq.0.and.dev(ii:ii).gt.' ') inbl=ii
00746 if (inbl.gt.0.and.dev(ii:ii).eq.' ') go to 100
00747 end do
00748 ii=nd+1
00749 100 if (inbl.gt.0) then
00750 npsf=ii-inbl
00751 psfile(1:npsf)=dev(inbl:ii-1)
00752 ikeepps=1
00753 iprintps=0
00754 end if
00755 end if
00756 c
00757 end
