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 program mcdraw main
00021 c
00022 c Call the mcdraw routines via a C routine which allocates
00023 c memory for all internal arrays.
00024 c
00025 character*200 arg,string
00026 character c1,c2
00027 equivalence (c1,arg(1:1)),(c2,arg(2:2))
00028 c
00029 integer which,s,size
00030 c
00031 c Defaults:
00032 c
00033 size = 10000
00034 string = ' '
00035 which = 0
00036 c
00037 c Note use of the generic functions nparams and getparam.
00038 c
00039 i = 0
00040 do while (i.lt.nparams())
00041 i = i + 1
00042 call getparam(i,arg)
00043 io = 0
00044 c
00045 if (c1.eq.'-') then
00046 c
00047 c Make the second character lowercase.
00048 c
00049 if (c2.le.'Z') c2 = char(ichar(c2)+32)
00050 c
00051 if (c2.eq.'n'.or.c2.eq.'s') then
00052 i = i + 1
00053 call getparam(i,arg)
00054 read(arg,'(i10)',iostat=io)s
00055 if (io.eq.0.and.s.gt.1.and.s.le.10000000)
00056 & size = s
00057 else if (c2.eq.'f') then
00058 which = 1
00059 i = i + 1
00060 call getparam(i,string)
00061 else if (c2.eq.'c'.or.c2.eq.'i'.or.c2.eq.'l') then
00062 which = 2
00063 i = i + 1
00064 call getparam(i,string)
00065 else if (c2.eq.'h') then
00066 call input help
00067 go to 99999
00068 else
00069 io = 1
00070 end if
00071 c
00072 else
00073 c
00074 read(arg,'(i10)',iostat=io)s
00075 if (io.eq.0.and.s.gt.1.and.s.le.10000000)
00076 & size = s
00077 c
00078 end if
00079 c
00080 if (io.ne.0) then
00081 call input help
00082 go to 99999
00083 end if
00084 c
00085 end do
00086 c
00087 call mcdrawc(size,string,which)
00088 c
00089 99999 end
00090
00091
00092 subroutine input help
00093 c
00094 c Print out basic command-line help.
00095 c
00096 write(6,'(a)')
00097 & 'Options: -h(H) help'
00098 write(6,'(a)')
00099 & ' [-n(s)] # '
00100 & 'specify maximum array length'
00101 write(6,'(a)')
00102 & ' -f(F) file '
00103 & 'take initial input from a file'
00104 write(6,'(a)')
00105 & ' -c(l) line '
00106 & 'specify initial command line'
00107 c
00108 end
00109
00110
00111 block data init mcd data
00112 save
00113 c
00114 c Version number:
00115 c
00116 character*20 version
00117 common /mcd version/ nversion,version
00118 c
00119 c Basic mcdraw plotting information:
00120 c ---------------------------------
00121 c
00122 common /mcd color/ icolor
00123 common /initial/ roff0,soff0,hn0,hs0,hp0
00124 common /draw params/ roff,soff,aspect1,xlen,ylen,
00125 & hs,hn,hp,idevset,jbox,iorig
00126 common /fr plain/iplain
00127 c
00128 c Mcdraw frame parameters:
00129 c -----------------------
00130 c
00131 common /frame params 1/ xmin,xmax,ymin,ymax,modex,modey
00132 character*80 xttl,yttl
00133 common /frame params 2/ xttl,yttl
00134 c
00135 c History:
00136 c -------
00137 c
00138 parameter (NHMAX = 500)
00139 common /histnums/ lhist(NHMAX),nhist,ishist(NHMAX),
00140 & izhist(NHMAX),ibhist(NHMAX)
00141 c
00142 c Internal modes:
00143 c --------------
00144 c
00145 common /replay/ ireplay
00146 common /prompt/ iprompt
00147 c
00148 c File input:
00149 c ----------
00150 c
00151 common /file input/ inpmode
00152 c
00153 common /data offset/ delx,dely,delz,facx,facy,facz
00154 c
00155 c "Local" data:
00156 c ------------
00157 c
00158 character*1 plot_symbol
00159 common /mcd_local/ offx,offy,offxsave,offysave,offlabel,
00160 $ angle,anglesave,rloc,sloc,
00161 $ iweight,iwtsto,jth,jsym,itype,
00162 $ ibox,ierbox(0:4),plot_symbol
00163 c
00164 data nversion/3/version/'2.1'/
00165 c
00166 data icolor/1/
00167 data roff0/.175/soff0/.125/hn0/.2/hs0/.25/hp0/.1/
00168 data aspect1/-1./idevset/0/jbox/0/iorig/0/
00169 data iplain/0/
00170 c
00171 data xmin/0./xmax/1./modex/2/xttl/' '/
00172 & ymin/0./ymax/1./modey/2/yttl/' '/
00173 c
00174 data nhist/0/
00175 c
00176 data ireplay/0/
00177 data iprompt/1/
00178 data inpmode/0/
00179 data delx/0./dely/0./delz/0./facx/1./facy/1./facz/1./
00180 c
00181 data offx/0./offy/0./offxsave/0./offysave/0./
00182 data offlabel/0.5/
00183 data angle/0./anglesave/0./
00184 data rloc/0./sloc/0./
00185 data iweight/1/iwtsto/1/
00186 data jth/0/
00187 data jsym/0/
00188 data plot_symbol/' '/
00189 data itype/0/
00190 data ibox/0/
00191 data (ierbox(k),k=0,4)/0,1,1,1,1/
00192 c
00193 end
00194
00195
00196 subroutine mcdraw(x,y,z,arr,w,nmax,instring,iwhich)
00197 save
00198 c
00199 c Interactive interface to the MCPAK plotting routines.
00200 c
00201 integer nmax,iwhich
00202 dimension x(1),y(1),z(1),arr(nmax,3),w(1)
00203 character*(*) instring
00204 c
00205 c >>>>> For now, w really IS of dimension 1! <<<<<
00206 c
00207 c NOTE: arr and (x, y, z) actually share the same space,
00208 c so they are effectively equivalenced to one another.
00209 c
00210 c......................................................................
00211 c
00212 c General mcpak common information (used "readonly"):
00213 c --------------------------------------------------
00214 c
00215 c Plotting information:
00216 c --------------------
00217 c
00218 character*80 device
00219 common /plot device/ device,aspect,idev
00220 common /plot sizes/ xsize,ysize
00221 common /plot origin/ ro,so
00222 common /framesize/ nxpix,nx0,xfac,nypix,ny0,yfac
00223 common /input posn/ iposn,jposn
00224 common /mcpak_colormap/ ncolors
00225 common /dev details/ itek,ivers
00226 common /xwin init/ no_new_xwin
00227 character*80 colormapfile
00228 common /mcdraw_colormap_file/ colormapfile
00229 c
00230 c Eframe options and parameters:
00231 c -----------------------------
00232 c
00233 common /scales/ xl,xr,dinchx,ybot,ytop,dinchy,rlen,slen
00234 common /fr ticks/ tiks(3)
00235 c
00236 c......................................................................
00237 c
00238 c Basic mcdraw plotting information:
00239 c ---------------------------------
00240 c
00241 common /mcd color/ icolor
00242 common /initial/ roff0,soff0,hn0,hs0,hp0
00243 common /draw params/ roff,soff,aspect1,xlen,ylen,
00244 & hs,hn,hp,idevset,jbox,iorig
00245 common /compress frames/ icompress
00246 common /fr plain/iplain
00247 c
00248 c Mcdraw frame parameters:
00249 c -----------------------
00250 c
00251 common /frame params 1/ xmin,xmax,ymin,ymax,modex,modey
00252 character*80 xttl,yttl
00253 common /frame params 2/ xttl,yttl
00254 c
00255 c History:
00256 c -------
00257 c
00258 parameter (NHMAX = 500)
00259 c
00260 character*200 history(NHMAX),lsto
00261 common /histchars/ history
00262 common /histnums/ lhist(NHMAX),nhist,ishist(NHMAX),
00263 & izhist(NHMAX),ibhist(NHMAX)
00264 c
00265 c Internal modes:
00266 c --------------
00267 c
00268 common /replay/ ireplay
00269 common /prompt/ iprompt
00270 c
00271 c File input:
00272 c ----------
00273 c
00274 common /file input/ inpmode
00275 character*15 modename(0:1)
00276 common /token delim/ nsep
00277 c
00278 character*1 comment
00279 common /file comment/ icomment,comment
00280 c
00281 c Optional offsets and scales for data (rescale to single precision).
00282 c
00283 common /data offset/ delx,dely,delz,facx,facy,facz
00284 c
00285 c......................................................................
00286 c
00287 c Uninitialized mcdraw common blocks:
00288 c ----------------------------------
00289 c
00290 c Help:
00291 c ----
00292 c
00293 common /hlevel/ ihelp
00294 character*2 hindx
00295 common /hindex/ hindx
00296 c
00297 common /resid/ resi
00298 c
00299 c......................................................................
00300 c
00301 c Local variables and parameters:
00302 c ------------------------------
00303 c
00304 character*1 plot_symbol
00305 common /mcd_local/ offx,offy,offxsave,offysave,offlabel,
00306 $ angle,anglesave,rloc,sloc,
00307 $ iweight,iwtsto,jth,jsym,itype,
00308 $ ibox,ierbox(0:4),plot_symbol
00309 c
00310 dimension narr(3)
00311 c
00312 c Zooming and rescaling:
00313 c ---------------------
00314 c
00315 parameter (NZMAX = 50)
00316 dimension xlzoom(NZMAX),xrzoom(NZMAX),
00317 & ybzoom(NZMAX),ytzoom(NZMAX)
00318 c
00319 parameter (NBMAX = 50)
00320 dimension xbox(NBMAX),ybox(NBMAX),bscale(NBMAX)
00321 c
00322 character line*2000,loopstring*2000,
00323 & datafile*300,
00324 & home*200,stringsto*200,label*200,labelsto*200,
00325 & cwd*150,oldcwd*150,tempcwd*150,
00326 & input*80,temp*80,keyword*80,tmp*400,
00327 & c1*1,c2*1,c3*1,c4*1
00328 c
00329 character*40 token(20)
00330 character*120 pwd
00331 c
00332 dimension xpoly(4),ypoly(4)
00333 dimension iarg(3),ipat(4)
00334 c
00335 integer mysystem
00336 logical audio,gfxin
00337 c
00338 equivalence (n,nx,narr(1)),(ny,narr(2)),(nz,narr(3))
00339 equivalence (c1,input(1:1)),(c2,input(2:2)),
00340 $ (c3,input(3:3)),(c4,input(4:4))
00341 c
00342 parameter (REDUCE = 0.9)
00343 parameter (ISEED = 42)
00344 c
00345 integer num_win, curr_win
00346 real*8 random
00347 c
00348 c......................................................................
00349 c
00350 c Local initialization:
00351 c --------------------
00352 c
00353 data cwd(1:1)/'.'/ncwd/1/oldcwd(1:1)/'.'/noldcwd/1/
00354 data iopen/0/
00355 data inunit/5/
00356 data nrange/10000000/
00357 c
00358 data modename /'fast but stupid','clever but slow'/
00359 c
00360 data nhfull/0/
00361 data nstring/1/
00362 data nzoom/0/
00363 data nbox/0/
00364 data nhead0/0/nhead/0/
00365 data ihmode/0/
00366 data icsave/1/
00367 data jreplay/0/
00368 data npl/1/
00369 data audio/.true./
00370 data iherr/0/ihsave/0/
00371 c
00372 data loop/0/loop1/1/loop2/1/linc/1/
00373 data nlabel/1/nlabelsto/0/
00374 c
00375 data rgin/0./sgin/0./
00376 data narr/3*0/
00377 data ix/0/iy/0/iz/0/
00378 c
00379 c......................................................................
00380 c
00381 hslast = hs
00382 hnlast = hn
00383 hplast = hp
00384 c
00385 dummy = random(ISEED)
00386 c
00387 c do 2 i=1,nmax
00388 c w(i)=1.
00389 c2 continue
00390 c
00391 w(1)=1.
00392 c ***** For now, w really is of dimension 1. *****
00393 c
00394 nl = -1
00395 c
00396 c Initialize some box parameters.
00397 c
00398 hn = hn0
00399 hs = hs0
00400 hp = hp0
00401 c
00402 c Allow the possibility of starting off with file or command-line
00403 c input instead of using any ~/.mcdrc file.
00404 c
00405 7 if (iwhich.eq.1) then
00406 inunit = 7
00407 open(inunit,file=instring,
00408 & status='old',form='formatted',iostat=io)
00409 if (io.ne.0) then
00410 write(6,*)'Error reading initial input file.'
00411 go to 99999
00412 else
00413 write(6,*)'Initial input taken from ',instring
00414 end if
00415 else if (iwhich.eq.2) then
00416 line = instring
00417 nl = len(instring)
00418 else
00419 c
00420 c Is there a standard startup file?
00421 c
00422 call mygetenv('HOME',home)
00423 c
00424 io1 = 0
00425 do 5 i=80,1,-1
00426 if (io1.eq.0.and.inunit.eq.5
00427 & .and.home(i:i).gt.' ') then
00428 open(7,file='.mcdrc',status='old',iostat=io)
00429 if (io.ne.0) open(7,file=home(1:i)
00430 & status='old',iostat=io1)
00431 if (io1.eq.0) inunit = 7
00432 end if
00433 5 continue
00434 c
00435 end if
00436 c
00437 c***************************************************************************
00438 c***************************************************************************
00439 c
00440 9 iscolon=0
00441 c
00442 c In operation, iscolon points to the end of the next (sub)command.
00443 c
00444 c Note:
00445 c
00446 c "go to 10" ==> get next subcommand
00447 c "go to 12" ==> get next command line (use discouraged)
00448 c "go to 1001" ==> error handling (such as it is)
00449 c "go to 99999" ==> quit
00450 c
00451 10 if (iscolon.gt.nl) then
00452 c
00453 if (iprompt.eq.1) call devoff
00454 c
00455 c Get the next command line
00456 c -------------------------
00457 c
00458 12 if (loop.ge.0) loop = loop + linc
00459 c
00460 xloop = float(loop-loop1)*float(loop2-loop)
00461 if (xloop.lt.0.) then
00462 c
00463 if (ireplay.gt.0.and.ireplay.le.jreplay) then
00464 c
00465 jh = ireplay
00466 do while (jh.gt.NHMAX)
00467 jh = jh - 1
00468 end do
00469 c
00470 line = history(jh)
00471 nl = lhist(jh)
00472 call setisave(ishist(jh))
00473 izoom = izhist(jh)
00474 c
00475 write(6,10013)ireplay,line(1:nl)
00476 10013 format('Replay (',i5,'): ',a)
00477 ireplay = ireplay + 1
00478 else
00479 ireplay = 0
00480 jreplay = 0
00481 call getline(inunit,line,nl,iprompt,nhist)
00482 end if
00483 c
00484 ihset = 1
00485 c
00486 else
00487 c
00488 c We are in a loop, so just use the loop string.
00489 c
00490 line = loopstring
00491 nl = nlstring
00492 c
00493 c Suppress addition to the history list.
00494 c
00495 ihset = 0
00496 c
00497 end if
00498 c
00499 c Start processing the ENTIRE line
00500 c --------------------------------
00501 c
00502 c Note that historical references are NOT expanded at this stage,
00503 c unless it is explicitly requested, or needed for substitution.
00504 c This is in order to save space, in case of multiple or nested
00505 c references.
00506 c
00507 c 1a) Expand repeat (!!) references immediately (!! --> !nhist).
00508 c
00509 call expandr(line,nl)
00510 c
00511 c 1b) Expand references of the form "!string" (--> !ihist).
00512 c
00513 call expands(line,nl)
00514 c
00515 c 2) Strip off trailing blanks and non-significant semicolons.
00516 c
00517 call stripbl(line,nl,*10,*12)
00518 c
00519 c 3) Check for verify (echo-only) mode (trailing \).
00520 c
00521 call chktail(line,nl,'\\',noexe,1)
00522 c
00523 c 4) Check for explicit suppression of recursive expansion
00524 c (leading ~)
00525 c
00526 call chkhead(line,nl,'~',isuppr,1)
00527 c
00528 c 5) Check for forced explicit expansion (leading %).
00529 c
00530 call chkhead(line,nl,'%',iexpand,1)
00531 c
00532 c Note that explicit expansion and substitution are not
00533 c completely compatible, as the substitution should only be
00534 c performed after a single level of history expansion.
00535 c Thus, if recursive expansion is forced, DO IT NOW, and don't
00536 c worry about its effects on substitutions.
00537 c
00538 if (iexpand.eq.1) call expandl(line,nl,isuppr,*9)
00539 c
00540 c 6) Check for substitutions (.....^xxx"yyy" substitutes yyy
00541 c for xxx).
00542 c
00543 c Substitutions are performed on a command-by-command basis.
00544 c Continue making substitutions until none remain.
00545 c
00546 call applysubs(line,nl,*9)
00547 c
00548 c 7) Finally, update the history list
00549 c
00550 if (ireplay.eq.0.and.ihset.eq.1)
00551 & call updhist(line,nl,nzoom,nbox)
00552 c
00553 go to 9
00554 c
00555 end if
00556 c
00557 c***************************************************************************
00558 c***************************************************************************
00559 c
00560 c Split the line up into individual commands.
00561 c ------------------------------------------
00562 c
00563 15 call getnext(line,nl,iscolon,ic0,ic1,input,nin)
00564 c
00565 c Note that input does NOT have a trailing semicolon.
00566 c
00567 c Recursively expand any historical references.
00568 c --------------------------------------------
00569 c
00570 do i=1,nin
00571 if (input(i:i).gt.' ') then
00572 if (input(i:i).ne.'!') go to 50
00573 if (i.ge.nin) go to 1001
00574 c
00575 c Decode the range reference in the line:
00576 c
00577 call rdecode(input(i+1:nin),nhist-1,ihmin,ihmax,*1001)
00578 go to 35
00579 end if
00580 end do
00581 go to 10
00582 c
00583 c Save the rest of the line...
00584 c
00585 35 nlsto = 0
00586 if (ic1.lt.nl) then
00587 nlsto = nl - ic1 + 1
00588 lsto(1:nlsto) = line(ic1:nl)
00589 end if
00590 c
00591 c (N.B. the leading ";" at position ic1 IS saved here.)
00592 c
00593 c Expand the history into the line after ic0. Note that expandh
00594 c does not place a trailing semicolon at the end of the inserted
00595 c string, and does not alter nl or ic0. The process of saving,
00596 c expanding, and restoring the rest of the line overwrites the
00597 c original reference.
00598 c
00599 call expandh(line,nl,ic0,ihmin,ihmax,lextra,iret)
00600 c
00601 if (iret.ne.0) then
00602 nhist = nhist - 1
00603 iscolon = nl + 1
00604 go to 10
00605 end if
00606 c
00607 c Restore the rest of the line. (Note: this would be a good
00608 c place for a consistency check, as the string lengths are not
00609 c forced to agree...)
00610 c
00611 nl = nl - nin + lextra
00612 if (nlsto.gt.0) then
00613 line(ic0+1+lextra:nl) = lsto(1:nlsto)
00614 end if
00615 c
00616 c Go back and continue decomposing the line. This process
00617 c continues until the next command found contains no historical
00618 c references.
00619 c
00620 iscolon = ic0
00621 go to 15
00622 c
00623 c***************************************************************************
00624 c
00625 c Strip leading blanks, convert the current command to lowercase,
00626 c and locate the start of the argument list.
00627 c
00628 50 nino = nin
00629 call cleanup(input,nin,istart,*10)
00630 c
00631 c Also shift line left, to reduce the (small) chance of overflow.
00632 c
00633 if (ic0.gt.0) then
00634 call shiftstr(line,nl,ic0)
00635 iscolon = iscolon - ic0
00636 ic1 = ic1 - ic0
00637 ic0 = 0
00638 end if
00639 c
00640 c***************************************************************************
00641 c***************************************************************************
00642 c
00643 c Now decode the command line.
00644 c ---------------------------
00645 c
00646 c Notes: The entire command is input(1:nin)
00647 c The argument list is input(istart:nin)
00648 c The characters c1, c2, and c3 are, respectively,
00649 c input(1:1), input(2:2), and input(3:3)
00650 c
00651 c >>>> (The following long "if...then...else" construction should be
00652 c >>>> replaced by a "case" statement, if FORTRAN ever gets one...)
00653 c
00654 c Clean up any pending X graphics commands (force synchronism).
00655 c
00656 call win_flush
00657 c
00658 if (noexe.eq.1) then
00659 c
00660 c Echo only.
00661 c
00662 write(6,*)input(1:nin)
00663 c
00664 else if (c1.eq.'=') then
00665 c
00666 c =N: Subdivision of the plotting area into quarters.
00667 c First flush the box stack, if any.
00668 c
00669 if (nbox.gt.0) then
00670 write(temp,'(i4)')nbox
00671 nt = 4
00672 if (c2.eq.'0') then
00673 c
00674 c (Necessary to make sure the screen is cleared.)
00675 c
00676 temp(5:6) = ' 1'
00677 nt = 6
00678 end if
00679 call popbox(temp,nt,ierbox,xbox,ybox,bscale,nbox,*1001)
00680 end if
00681 c
00682 c Choose and initialize a new output area.
00683 c
00684 call newbox(input,nin,ierbox,*1001)
00685 c
00686 else if (c1.eq.'*') then
00687 c
00688 c Toggle small/large amount of output.
00689 c
00690 iprompt = 1 - iprompt
00691 c
00692 else if (c1.eq.'2') then
00693 c
00694 c 2D: Two-dimensional plot of the specified array.
00695 c Details in subroutine "ez2dplot."
00696 c
00697 call sdecode(input(istart:nin),1,iarg,*1001)
00698 if (iarg(1).le.0) iarg(1) = 3
00699 if (narr(iarg(1)).le.0) then
00700 if (iprompt.eq.1) write(6,*)'No points !'
00701 go to 1001
00702 end if
00703 c
00704 if (idevset.eq.0.or.xlen.le.0.) call setup(' ','2d')
00705 if (ibox.eq.0) call box(0.,xlen,0.,ylen)
00706 c
00707 call ez2dplot(arr(1,iarg(1)),narr(iarg(1)),
00708 & xlen,ylen,iprompt,itype,*1001)
00709 c
00710 else if (c1.eq.'3') then
00711 c
00712 c 3D: Three-dimensional plot of the specified array.
00713 c Details in subroutine "ez3dplot."
00714 c
00715 call sdecode(input(istart:nin),1,iarg,*1001)
00716 if (iarg(1).le.0) iarg(1) = 3
00717 if (narr(iarg(1)).le.0) then
00718 if (iprompt.eq.1) write(6,*)'No points !'
00719 go to 1001
00720 end if
00721 c
00722 call getorigin(rsave,ssave)
00723 call setorigin(0.,0.)
00724 call ez3dplot(arr(1,iarg(1)),narr(iarg(1)),iprompt,*1001)
00725 call setorigin(rsave,ssave)
00726 c
00727 else if (c1.eq.'a') then
00728 c
00729 if (c2.eq.' ') then
00730 go to 1001
00731 c
00732 else if (c2.eq.'n') then
00733 c
00734 if (c3.ne.'-') then
00735 c
00736 c AN: Alter drawing angle (for strings).
00737 c
00738 call readrq(input(istart:nin),1,
00739 & aa,dum,dum,dum,*1001)
00740 c
00741 anglesave = angle
00742 angle = aa
00743 else
00744 c
00745 c AN-: Restore previous drawing angle (for strings).
00746 c
00747 aa = angle
00748 angle = anglesave
00749 anglesave = aa
00750 end if
00751 c
00752 else if (c2.eq.'s') then
00753 c
00754 c AS: Alter default aspect ratio, relative to the physical
00755 c shape of the display. The value of aspect1 set here
00756 c actually goes into effect as soon as the display is
00757 c (re)initialized ("de") or resized ("=1," "bo," etc.).
00758 c
00759 if (ireplay.eq.0) then
00760 call readrq(input(istart:nin),1,
00761 & aspect1,dum,dum,dum,*1001)
00762 call newbox('=-0',3,ierbox,*1001)
00763 end if
00764 c
00765 else if (c2.eq.'r') then
00766 c
00767 c AR: Draw an arrow, with positions measured in "inches"
00768 c or user units, depending on the box status.
00769 c
00770 c ARH: Specify the size of the arrowhead, in "inches".
00771 c
00772 if (c3.eq.'h') then
00773 call readrq(input(istart:nin),1,
00774 & head_size,dum, dum, dum,*1001)
00775 call set_arrow_head(head_size)
00776 else
00777 call readrq(input(istart:nin),4,
00778 & xtail,ytail,xhead,yhead,*1001)
00779 c
00780 call arrow(xtail,ytail,xhead,yhead,1-ibox)
00781 end if
00782 c
00783 else if (c2.eq.'u') then
00784 c
00785 c AU: Take autocorrelation of specified array (y or z).
00786 c Assume that x holds equally-spaced data points.
00787 c
00788 call sdecode(input(istart:nin),1,ia,*1001)
00789 c
00790 if (ia.eq.1) go to 1001
00791 c
00792 ny0 = narr(ia)
00793 call cautocorrel(arr(1,ia),narr(ia))
00794 c
00795 c On return, the specified array has been replaced by its
00796 c (normalized) autocorrelation function, and reduced in length
00797 c by a factor of two. If (as will often be the case), the
00798 c array is y and x contained time (in equally-spaced steps),
00799 c simply dividing nx by two will leave an x-array suitable
00800 c for plotting (i.e. time --> tau).
00801 c
00802 if (nx.eq.ny0) nx = narr(ia)
00803 if (iprompt.ne.0) write(6,*)'Array size now = ',narr(ia)
00804 c
00805 else
00806 c
00807 c A* (etc.): Perform vector arithmetic on two arrays.
00808 c
00809 call varith(input,istart,nin,arr,nmax,narr,iprompt,
00810 & *1001)
00811 c
00812 end if
00813 c
00814 else if (c1.eq.'b') then
00815 c
00816 if (c2.eq.'i'.or.c2.eq.'+') then
00817 c
00818 c BI/B+: Increase the box size.
00819 c
00820 xlen = xlen/REDUCE
00821 ylen = ylen/REDUCE
00822 c
00823 else if ((c2.eq.' '.or.c2.eq.'n'.or.c2.eq.'o'.or.c2.eq.'b')
00824 & .and.(nin.le.3.or.istart.ge.nin)) then
00825 c
00826 c B/BB/BN: Draw a box and set up scalings for plotting.
00827 c
00828 if (idevset.eq.0) call setup(' ','box')
00829 call devon
00830 call clrstr
00831 c
00832 call getmod(i1,i2,i3,i4,i5)
00833 if (c2.eq.'n'.or.c2.eq.'b') then
00834 c
00835 c Scaling only.
00836 c
00837 call setmod(1,i2,i3,i4,i5)
00838 else
00839 call setmod(0,i2,i3,i4,i5)
00840 end if
00841 c
00842 call eframe(xmin,xmax,xlen,modex,xttl,
00843 & ymin,ymax,ylen,modey,yttl)
00844 c
00845 if (c2.eq.'b') call box(0.,xlen,0.,ylen)
00846 c
00847 ibox = 1
00848 call setmod(i1,i2,i3,i4,i5)
00849 c
00850 else if (c2.eq.'c') then
00851 c
00852 c BC: Toggle compression of frames in "4-box" format.
00853 c
00854 icompress = 1 - icompress
00855 c
00856 else if ((c2.eq.'o'.or.c2.eq.' ').and.istart.le.nin) then
00857 c
00858 c BO: Offset and rescale the box parameters.
00859 c -- Generalization of "=1," etc.
00860 c
00861 if (nbox.ge.NBMAX) then
00862 if (iprompt.eq.1) write(6,*)' Box stack overflow.'
00863 go to 1001
00864 end if
00865 c
00866 if (idevset.eq.0) call setup(' ','bo')
00867 call offbox(input(istart:nin),nin-istart+1,
00868 & ierbox,xbox,ybox,bscale,nbox,*1001)
00869 c
00870 else if (c2.eq.'-') then
00871 c
00872 c B-: Pop previous box parameters from the stack.
00873 c
00874 call popbox(input(istart:nin),nin-istart+1,
00875 & ierbox,xbox,ybox,bscale,nbox,*1001)
00876 c
00877 else if (c2.eq.'s') then
00878 c
00879 c BS: Display the box stack.
00880 c
00881 if (ireplay.eq.0.and.iprompt.eq.1) then
00882 do 80 ib=1,nbox
00883 write(6,*)ib,xbox(ib),ybox(ib),bscale(ib)
00884 80 continue
00885 end if
00886 c
00887 else
00888 go to 1001
00889 end if
00890 c
00891 else if (c1.eq.'c') then
00892 c
00893 if (c2.eq.'o') then
00894 if (c3.eq.'-') then
00895 c
00896 c CO-: Restore the previous plotting color.
00897 c
00898 ic = icsave
00899 else
00900 c
00901 c CO: Set the current plotting color.
00902 c
00903 call readiq(input(istart:nin),1,
00904 & ic,idum,idum,idum,*1001)
00905 end if
00906 c
00907 icsave = icolor
00908 icolor = ic
00909 call color(icolor)
00910 c
00911 else if (c2.eq.'m') then
00912 c
00913 c CM: Set or display the color map, if appropriate.
00914 c
00915 if (idevset.eq.0)call setup(' ','cm')
00916 if (idev.lt.15.or.idev.gt.17) go to 1001
00917 c
00918 if (ireplay.eq.0) then
00919 c
00920 idisp = 1
00921 ier = 0
00922 if (istart.le.nin) then
00923 if (idev.eq.15) then
00924 call readmap(cwd(1:ncwd)//
00925 $ '/'//input(istart:nin))
00926 ncolors = 256
00927 idisp = 0
00928 else if (idev.eq.17) then
00929 c
00930 c Palette names are relative to cwd, unless
00931 c name begins with a "/". In addition, we will
00932 c search Starlab if the environment is set.
00933 c
00934 if (input(istart:istart).ne.'/') then
00935 c
00936 c See if the file exists:
00937 c
00938 open(99,file=cwd(1:ncwd)//'/'
00939 $ //input(istart:nin),
00940 $ status='old',iostat=io)
00941 if (io.eq.0) then
00942 close(99)
00943 call set_colormap(cwd(1:ncwd)//
00944 $ '/'//input(istart:nin),ier)
00945 else
00946 c
00947 c Try Starlab:
00948 c (This mess should be in a separate routine!)
00949 c
00950 temp = ' '
00951 call mygetenv('STARLAB_PATH',temp)
00952 i = len(temp)
00953 do while (i.gt.0)
00954 if (temp(i:i).gt.' ') then
00955 temp(i+1:i+17)
00956 $ = '/src/gfx/palettes'
00957 i = -i - 17
00958 end if
00959 i = i - 1
00960 end do
00961 if (i.ge.0) then
00962 if (iprompt.eq.1) write(6,'(a)')
00963 $ 'Color map file not found.'
00964 ier = 1
00965 else
00966 open(99,file=temp(1:-i-1)//'/'
00967 $ //input(istart:nin),
00968 $ status='old',iostat=io)
00969 if (io.eq.0) then
00970 close(99)
00971 call set_colormap(
00972 $ temp(1:-i-1)//'/'//
00973 $ input(istart:nin),ier)
00974 else
00975 if (iprompt.eq.1)
00976 $ write(6,'(a)')
00977 $ 'Color map file not found.'
00978 ier = 1
00979 end if
00980 end if
00981 end if
00982 else
00983 call set_colormap(input(istart:nin),ier)
00984 end if
00985 idisp = 0
00986 end if
00987 if (ier.eq.0) colormapfile = cwd(1:ncwd)//
00988 $ '/'//input(istart:nin)
00989 end if
00990 c
00991 if (idisp.eq.1) then
00992 call getfill(ifsave)
00993 c
00994 dr = .2
00995 xpoly(1) = -ro
00996 xpoly(2) = xpoly(1) + dr
00997 xpoly(3) = xpoly(2)
00998 xpoly(4) = xpoly(1)
00999 c
01000 ds = ysize/ncolors
01001 do 90 j=0,ncolors-1
01002 s = j*ds
01003 ypoly(1) = s - so
01004 ypoly(2) = ypoly(1)
01005 ypoly(3) = ypoly(2) + ds
01006 ypoly(4) = ypoly(3)
01007 call setfill(j)
01008 call polyfill(xpoly,ypoly,4)
01009 call color(icolor)
01010 if (ncolors.lt.64)
01011 $ call polydraw(xpoly,ypoly,4)
01012 90 continue
01013 c
01014 if (ifsave.ge.0) then
01015 call setfill(ifsave)
01016 else
01017 call unsetfill
01018 end if
01019 end if
01020 c
01021 end if
01022 c
01023 else if (c2.eq.'b') then
01024 c
01025 c CB: Set the background color.
01026 c
01027 if (idev.ne.15.and.idev.ne.17) go to 1001
01028 c
01029 call readiq(input(istart:nin),1,
01030 & jcolor,idum,idum,idum,*1001)
01031 call background(jcolor)
01032 c
01033 else if (c2.eq.'d') then
01034 c
01035 c CD: Change working directory.
01036 c
01037 if (c3.eq.'-') then
01038 tempcwd = cwd
01039 ntempcwd = ncwd
01040 cwd = oldcwd
01041 ncwd = noldcwd
01042 oldcwd = tempcwd
01043 noldcwd = ntempcwd
01044 else
01045 if (istart.gt.nin) then
01046 oldcwd = cwd
01047 noldcwd = ncwd
01048 cwd = '.'
01049 ncwd = 1
01050 else
01051 if (input(istart:istart).eq.'/') then
01052 oldcwd = cwd
01053 noldcwd = ncwd
01054 cwd(1:nin-istart+1) = input(istart:nin)
01055 ncwd = nin-istart+1
01056 else if (input(istart:istart).eq.'~') then
01057 c
01058 c Must explicitly expand this reference.
01059 c
01060 call mygetenv('HOME',tempcwd)
01061 do i=len(cwd),1,-1
01062 if (tempcwd(i:i).gt.' ') go to 100
01063 end do
01064 if (iprompt.eq.1)
01065 $ write(6,*)'Can''t expand ~'
01066 go to 1001
01067 c
01068 100 oldcwd = cwd
01069 noldcwd = ncwd
01070 ncwd = i
01071 cwd(1:ncwd) = tempcwd(1:ncwd)
01072 if (istart.lt.nin) then
01073 cwd(ncwd+1:ncwd+nin-istart+1)
01074 $ = input(istart+1:nin)
01075 ncwd = ncwd + nin-istart
01076 end if
01077 else
01078 oldcwd = cwd
01079 noldcwd = ncwd
01080 cwd(ncwd+1:ncwd+nin-istart+2)
01081 & = '/'//input(istart:nin)
01082 ncwd = ncwd+nin-istart+2
01083 end if
01084 end if
01085 end if
01086 c
01087 else if (c2.eq.'u') then
01088 c
01089 c CU: Replace an array by its cumulative sum.
01090 c
01091 call sdecode(input(istart:nin),1,iarg,*1001)
01092 if (iarg(1).le.0) go to 1001
01093 if (narr(iarg(1)).le.0) go to 1001
01094 c
01095 do i=2,narr(iarg(1))
01096 arr(i,iarg(1)) = arr(i-1,iarg(1)) + arr(i,iarg(1))
01097 end do
01098 c
01099 else if (c2.eq.'x'.or.c2.eq.'y'.or.c2.eq.'z') then
01100 c
01101 c CX/Y/Z: Read a standard image into the specified array.
01102 c
01103 call decode(c2,ia,*1001)
01104 c
01105 if (input(istart:istart).eq.'/') then
01106 c
01107 c Absolute path name.
01108 c
01109 datafile = input(istart:nin)
01110 ndata = nin-istart+1
01111 else
01112 c
01113 c Relative path name.
01114 c
01115 datafile = cwd(1:ncwd)//'/'//input(istart:nin)
01116 ndata = nin-istart+1+ncwd+1
01117 end if
01118 c
01119 call ctox(datafile(1:ndata),arr(1,ia),narr(ia),nmax)
01120 c
01121 if (iprompt.eq.1) write(6,*)narr(ia),' points read'
01122 c
01123 else if (c2.eq.' ') then
01124 c
01125 c C: Read x and y columns from the input file.
01126 c
01127 if (iopen.eq.0) then
01128 call devoff
01129 write(6,*)'c: No file open'
01130 go to 10
01131 end if
01132 c
01133 call readiq(input(istart:nin),2,
01134 & ix,iy,idum,idum,*1001)
01135 if (ix.le.0.or.iy.le.0.or.ix.eq.iy) go to 1001
01136 c
01137 call readcols(10,nhead,nrange,ix,iy,x,y,z,nx,nmax,
01138 & c1,1,iprompt,*1001)
01139 ny = nx
01140 c
01141 else
01142 go to 1001
01143 end if
01144 c
01145 else if (c1.eq.'d') then
01146 c
01147 if (c2.eq.' '.or.c2.eq.'r'.or.c2.eq.'a') then
01148 c
01149 c D: Draw a line to the specified point.
01150 c
01151 if (nin.lt.istart) then
01152 xloc = rgin
01153 yloc = sgin
01154 else
01155 call readrq(input(istart:nin),2,
01156 & xloc,yloc,dum,dum,*1001)
01157 c
01158 if (c2.ne.'a') then
01159 c
01160 c User coordinates.
01161 c
01162 if (ibox.ne.0)
01163 & call fr inches(xloc,yloc,xloc,yloc)
01164 else
01165 c
01166 c DA: Absolute coordinates.
01167 c
01168 xloc = xloc - ro
01169 yloc = yloc - so
01170 end if
01171 end if
01172 c
01173 call segment(rloc,sloc,xloc,yloc)
01174 rloc = xloc
01175 sloc = yloc
01176 c
01177 else if (c2.eq.'d') then
01178 c
01179 c DD: Draw a dashed line to the specified point.
01180 c DDA: Draw a dashed line to the specified absolute point.
01181 c
01182 call dplot(rloc,sloc,3)
01183 call readrq(input(istart:nin),2,
01184 & xloc,yloc,dum,dum,*1001)
01185 c
01186 if (c3.ne.'a') then
01187 c
01188 c DD: User coordinates.
01189 c
01190 if (ibox.ne.0)
01191 & call fr inches(xloc,yloc,xloc,yloc)
01192 else
01193 c
01194 c DDA: Absolute coordinates.
01195 c
01196 xloc = xloc - ro
01197 yloc = yloc - so
01198 end if
01199 c
01200 call dplot(xloc,yloc,2)
01201 rloc = xloc
01202 sloc = yloc
01203 c
01204 else if (c2.eq.'e') then
01205 c
01206 c DE: Specify (new) device and initialize.
01207 c
01208 if (ireplay.eq.0) then
01209 if (nin.lt.istart) then
01210 nin=istart
01211 input(istart:nin)=' '
01212 end if
01213 call setup(input(istart:nin),' ')
01214 call nobounds
01215 end if
01216 c
01217 else if (c2.eq.'i') then
01218 c
01219 c DI(FF): Differentiate second array with respect to the first,
01220 c placing the result in the third (default: second).
01221 c
01222 call sdecode(input(istart:nin),3,iarg,*1001)
01223 c
01224 if (iarg(1).eq.0) then
01225 c
01226 c Default is y(x) --> y.
01227 c
01228 iarg(1) = 1
01229 iarg(2) = 2
01230 else if (iarg(2).le.0) then
01231 if (iarg(1).eq.1) then
01232 iarg(2) = 2
01233 else
01234 iarg(2) = 1
01235 end if
01236 end if
01237 c
01238 if (iarg(3).le.0) iarg(3) = iarg(2)
01239 c
01240 if (narr(iarg(1)).le.0) then
01241 if (iprompt.eq.1) then
01242 call devoff
01243 write(6,*)'No points !'
01244 end if
01245 go to 1001
01246 end if
01247 c
01248 c Note that array iarg(1) is the independent variable,
01249 c whose length determines the number of elements used.
01250 c
01251 call differentiate(arr(1,iarg(1)),arr(1,iarg(2)),
01252 & arr(1,iarg(3)),narr(iarg(1)),
01253 & iprompt,*1001)
01254 narr(iarg(3)) = narr(iarg(1))
01255 c
01256 else if(c2.eq.'x'.or.c2.eq.'y'.or.c2.eq.'z') then
01257 c
01258 c DX(Y,Z): Take 10**(x, y, or z).
01259 c
01260 call decode(c2,ia,*1001)
01261 do 150 i=1,narr(ia)
01262 arr(i,ia)=10.**arr(i,ia)
01263 150 continue
01264 c
01265 end if
01266 c
01267 else if (c1.eq.'e') then
01268 c
01269 if (c2.eq.'a'.or.(c2.eq.' '.and.jbox.eq.0)) then
01270 c
01271 c EA: Erase entire screen.
01272 c
01273 159 if (idevset.eq.0)call setup(' ','erase')
01274 call devon
01275 call clear
01276 ibox = 0
01277 c
01278 c Explicit "go to" here because of the slightly illegal
01279 c jump into this loop from below.
01280 c
01281 go to 10
01282 c
01283 else if (c2.eq.' ') then
01284 c
01285 c E: Erase current plotting area.
01286 c
01287 160 if (idevset.eq.0.or.ibox.eq.0)call setup(' ','erase')
01288 call devon
01289 if (jbox.eq.0) then
01290 call clear
01291 else
01292 call erase(-roff,.5*xsize-roff,
01293 & -soff,.5*ysize-soff)
01294 end if
01295 c
01296 c Explicit "go to" here because of the slightly illegal
01297 c jump into this loop from below.
01298 c
01299 go to 10
01300 c
01301 else if (c2.eq.'c') then
01302 c
01303 c EC: Echo input.
01304 c
01305 if (ireplay.eq.0) write(6,*)input(istart:nin)
01306 c
01307 else if (c2.eq.'b') then
01308 c
01309 c EB: Erase interior of box.
01310 c
01311 if (ibox.eq.0)go to 1001
01312 call devon
01313 call erase(tiks(3),xlen-tiks(3),tiks(3),ylen-tiks(3))
01314 c
01315 else if (c2.eq.'l') then
01316 c
01317 c EL: Erase label area.
01318 c
01319 call erase(0.,xlen,ylen+.01,ylen+(offlabel+2.)*hs)
01320 c
01321 else if (c2.eq.'r') then
01322 if (c3.eq.'r'.or.c3.eq.'p') then
01323 if (n.le.0) go to 1001
01324 c
01325 c ERR: Error bars (from z):
01326 c ERP: Error bars (from z), limited by current point size:
01327 c
01328 if (c3.eq.'p'.and.jth.ne.0) then
01329 hh = hp
01330 else
01331 hh = 0.
01332 end if
01333 call errors(input,istart,nin,x,y,z,n,hh,*1001)
01334 c
01335 else if (c3.eq.'c') then
01336 if (n.le.0) go to 1001
01337 c
01338 c ERC: Specify error-bar cap size.
01339 c
01340 call readrq(input(istart:nin),1,
01341 & capsize,dum,dum,dum,*1001)
01342 c
01343 call setercap(capsize)
01344 c
01345 else
01346 c
01347 c ER: Erase all or part of the display.
01348 c
01349 do 165 i=nin,istart,-1
01350 if (input(i:i).gt.' ') go to 166
01351 165 continue
01352 c
01353 if (jbox.eq.0) then
01354 go to 159
01355 else
01356 go to 160
01357 end if
01358 c
01359 166 call readrq(input(istart:nin),4,
01360 & x1,x2,y1,y2,*1001)
01361 c
01362 if (idevset.eq.0) call setup(' ','erase')
01363 if (ibox.eq.1) call fr inches(x1,y1,x1,y1)
01364 if (ibox.eq.1) call fr inches(x2,y2,x2,y2)
01365 call devon
01366 call erase(x1,x2,y1,y2)
01367 end if
01368 c
01369 else
01370 c
01371 c EX(Y,Z): Exponentiation of x, y, or z.
01372 c
01373 call decode(c2,ia,*1001)
01374 do 170 i=1,narr(ia)
01375 arr(i,ia)=exp(arr(i,ia))
01376 170 continue
01377 c
01378 end if
01379 c
01380 else if (c1.eq.'f') then
01381 c
01382 if (c2.eq.' '.or.c2.eq.'i') then
01383 c
01384 c F: Open an input file (as unit 10).
01385 c
01386 if (iopen.eq.1) close(10)
01387 c
01388 inb=0
01389 do 171 i=nin,istart,-1
01390 if (input(i:i).eq.char(92)) then
01391 c
01392 c (This is a backquote...).
01393 c
01394 if (inb.eq.0) then
01395 nhead0 = 0
01396 else
01397 call readiq(input(i+1:nin),1,
01398 & nhead0,idum,idum,idum,*1001)
01399 end if
01400 nhead = nhead0
01401 nin = i - 1
01402 go to 172
01403 end if
01404 if (input(i:i).gt.' ') inb=inb+1
01405 171 continue
01406 172 if (input(istart:istart).eq.'/') then
01407 c
01408 c Absolute path name.
01409 c
01410 datafile = input(istart:nin)
01411 ndata = nin-istart+1
01412 else
01413 c
01414 c Relative path name.
01415 c
01416 datafile = cwd(1:ncwd)//'/'//input(istart:nin)
01417 ndata = nin-istart+1+ncwd+1
01418 end if
01419 c
01420 open(10,file=datafile(1:ndata),status='old',
01421 & form='formatted',err=1001)
01422 iopen=1
01423 c
01424 else if (c2.eq.'c') then
01425 c
01426 c FC: Close the currently open data file.
01427 c
01428 if (iopen.eq.1) then
01429 close(10)
01430 iopen = 0
01431 end if
01432 c
01433 else if (c2.eq.'o') then
01434 c
01435 c FO: Toggle use of fancy font.
01436 c
01437 iplain = 1 - iplain
01438 c
01439 else if (c2.eq.'1'.or.c2.eq.'2') then
01440 c
01441 c F1(2): Perform a linear least-squares fit to y(x).
01442 c
01443 if (n.le.1) go to 1001
01444 if (c3.eq.'p'.and.ibox.eq.0) go to 1001
01445 c
01446 if (c2.eq.'1') then
01447 call fitxy(input,istart,nin,x,y,z,w,n,iprompt,ier)
01448 else
01449 call fitxyz(input,istart,nin,x,y,z,w,n,iprompt,ier)
01450 end if
01451 if (ier.ne.0) go to 1001
01452 c
01453 else if (c2.eq.'p'.or.c2.eq.'t') then
01454 c
01455 c FP(T): Perform a general (trig) polynomial fit to y(x)
01456 c (equal weighting).
01457 c
01458 if (ibox.eq.0.or.n.le.1) go to 1001
01459 c
01460 call genfit(input,istart,nin,x,y,z,n,1,iprompt,*1001)
01461 c
01462 else if (c2.eq.'z') then
01463 c
01464 c FZ: Perform a general polynomial fit to y(x) (z-weighting).
01465 c
01466 if (ibox.eq.0.or.n.le.1) go to 1001
01467 c
01468 call genfit(input,istart,nin,x,y,z,n,n,iprompt,*1001)
01469 c
01470 else
01471 go to 1001
01472 end if
01473 c
01474 else if (c1.eq.'g') then
01475 c
01476 if (c2.eq.'s') then
01477 c
01478 c GS: Read a character string from stdin or the save stack.
01479 c
01480 call getstring(input,istart,nin,stringsto)
01481 c
01482 c Get the length of the string.
01483 c
01484 do 175 i=200,1,-1
01485 if (stringsto(i:i).gt.' ') go to 176
01486 175 continue
01487 i = 1
01488 c
01489 176 nstring = i
01490 c
01491 else
01492 c
01493 c G: Get graphic input.
01494 c
01495 if (idevset.eq.0) call setup(' ','gin')
01496 c
01497 if (c2.eq.'c'.and.(idev.lt.15.or.idev.gt.17))
01498 & go to 1001
01499 c
01500 if (itek.eq.1.and.ivers.eq.0.and.iprompt.eq.1)
01501 & write(6,*)'Click mouse and hit <CR> for ',
01502 & 'graphic input in Tek mode.'
01503 c
01504 call getgfx(rgin,sgin)
01505 call devoff
01506 c
01507 if (c2.ne.'c') then
01508 c
01509 c Location:
01510 c
01511 if (idev.lt.15.or.idev.gt.17) then
01512 if (ibox.eq.0) then
01513 write(6,179)iposn,jposn,rgin,sgin
01514 179 format(' Pixels ',2i5,
01515 & ', coordinates ',2f7.3)
01516 else
01517 call fr users(rgin,sgin,xx,yy)
01518 write(6,10179)iposn,jposn,rgin,sgin,xx,yy
01519 10179 format(' Pixels ',2i5,', coords ',
01520 & 2f7.3,', values ',1p2e13.5)
01521 end if
01522 else
01523 if (ibox.eq.0) then
01524 write(6,20179)ro+rgin,so+sgin,rgin,sgin
01525 20179 format(' Position ',2f7.3,
01526 & ', coordinates ',2f7.3)
01527 else
01528 call fr users(rgin,sgin,xx,yy)
01529 write(6,21179)ro+rgin,so+sgin,rgin,sgin,
01530 & xx,yy
01531 21179 format(' Position',2f7.3,', coords',
01532 & 2f7.3,', values',1p2e13.5)
01533 end if
01534 end if
01535 c
01536 else
01537 c
01538 c GC: Color input from mouse:
01539 c
01540 icolor=ncolors*(sgin+so)/ysize
01541 write(6,'('' color = '',i3)')icolor
01542 call color(icolor)
01543 c
01544 end if
01545 c
01546 c GM(D): Move/draw options:
01547 c
01548 if (c2.eq.'d') call segment(rloc,sloc,rgin,sgin)
01549 c
01550 if (c2.eq.'d'.or.c2.eq.'m') then
01551 rloc=rgin
01552 sloc=sgin
01553 end if
01554 c
01555 end if
01556 c
01557 else if (c1.eq.'h'.or.c1.eq.'?') then
01558 c
01559 if (c2.eq.' '.or.c2.eq.'e') then
01560 c
01561 if (ireplay.eq.0) then
01562 c
01563 c H: Print out some helpful information.
01564 c
01565 call devoff
01566 ihelp = 1
01567 if (c1.eq.'h') ihelp = 2
01568 if (istart.gt.nin) then
01569 hindx = ' '
01570 else
01571 if (istart.lt.nin) then
01572 hindx = input(istart:istart+1)
01573 else
01574 hindx(1:1) = input(istart:istart)
01575 hindx(2:2) = ' '
01576 end if
01577 end if
01578 call help(' ')
01579 end if
01580 c
01581 else if (c1.eq.'?') then
01582 c
01583 go to 1001
01584 c
01585 else if (c2.eq.'h') then
01586 c
01587 c HH: Full help information!
01588 c
01589 call fullhelp
01590 c
01591 else if (c2.eq.'k') then
01592 c
01593 c HK: Keyword help.
01594 c
01595 if (ireplay.eq.0) then
01596 c
01597 call devoff
01598 ihelp = 2
01599 c
01600 if (istart.gt.nin) then
01601 hindx = ' '
01602 keyword = ' '
01603 else
01604 keyword = input(istart:nin)
01605 end if
01606 c
01607 call help(keyword)
01608 c
01609 end if
01610 c
01611 else if (c2.eq.'+') then
01612 c
01613 c H+: Audio (HAL) help on.
01614 c
01615 audio = .true.
01616 c
01617 else if (c2.eq.'-') then
01618 c
01619 c H-: Audio (HAL) help off.
01620 c
01621 audio = .false.
01622 c
01623 else if (c2.eq.'?') then
01624 c
01625 c H?: Height information.
01626 c
01627 call devoff
01628 write(6,*)'hp = ',hp
01629 write(6,*)'hn = ',hn
01630 write(6,*)'hs = ',hs
01631 c
01632 else if (c2.eq.'g') then
01633 c
01634 if (c3.eq.'e') then
01635 c
01636 c HGE: Toggle/set histogram error-bar mode.
01637 c
01638 if (istart.gt.nin) then
01639 iherr = 1 - iherr
01640 else
01641 call readiq(input(istart:nin),1,
01642 & iherr,idum,idum,idum,*1001)
01643 if (iherr.ne.0) iherr = 1
01644 end if
01645 c
01646 else if (c3.eq.'m') then
01647 c
01648 c HGM: Toggle/set histogram display mode.
01649 c
01650 if (istart.gt.nin) then
01651 ihmode = 1 - ihmode
01652 else
01653 call readiq(input(istart:nin),1,
01654 & ihmode,idum,idum,idum,*1001)
01655 if (ihmode.ne.0) ihmode = 1
01656 end if
01657 c
01658 else if (c3.eq.'s') then
01659 c
01660 c HGS: Toggle/set histogram-save mode.
01661 c
01662 if (istart.gt.nin) then
01663 if (ihsave.eq.0) then
01664 ihsave = 1
01665 else
01666 ihsave = 0
01667 end if
01668 else
01669 call readiq(input(istart:nin),1,
01670 & ihsave,idum,idum,idum,*1001)
01671 if (ihsave.ne.0.and.ihsave.ne.2) ihsave = 1
01672 end if
01673 c
01674 else
01675 c
01676 c HG: Draw a histogram.
01677 c
01678 call histogram(input,istart,nin,x,y,z,nx,ny,nz,
01679 & iherr,ihmode,ihsave,iprompt,*1001)
01680 ibox = 1
01681 end if
01682 c
01683 else if (c2.eq.'i') then
01684 c
01685 if (ireplay.eq.0) then
01686 c
01687 c HI: List history.
01688 c
01689 if (nin.lt.istart) then
01690 i1=1
01691 i2=nhist
01692 else
01693 call rdecode(input(istart:nin),nhist-1,
01694 & i1,i2,*1001)
01695 i1=max(1,min(nhist,i1))
01696 i2=max(i1,min(nhist,i2))
01697 end if
01698 call devoff
01699 do 210 ih=i1,i2
01700 jh=ih
01701 209 if (jh.gt.NHMAX) then
01702 jh=jh-1
01703 go to 209
01704 end if
01705 write(lsto(1:6),'(i4,'': '')')ih
01706 write(6,*)lsto(1:6),history(jh)(1:lhist(jh))
01707 210 continue
01708 end if
01709 c
01710 else if (c2.eq.'l') then
01711 c
01712 c HL: Specify horizontal y-axis label.
01713 c
01714 call getmod(i1,i2,i3,i4,i5)
01715 call setmod(i1,i2,i3,i4,0)
01716 c
01717 else if (c2.eq.'n') then
01718 c
01719 c HN: Set number height.
01720 c
01721 call modifyh(hnlast,hn,c3,input(istart:nin),*1001)
01722 call sethts(hs,hn)
01723 c
01724 else if (c2.eq.'p') then
01725 c
01726 c HP: Set point size.
01727 c
01728 call modifyh(hplast,hp,c3,input(istart:nin),*1001)
01729 c
01730 else if (c2.eq.'s') then
01731 c
01732 c HS: Set character height.
01733 c
01734 call modifyh(hslast,hs,c3,input(istart:nin),*1001)
01735 call sethts(hs,hn)
01736 c
01737 else
01738 go to 1001
01739 end if
01740 c
01741 else if (c1.eq.'i') then
01742 c
01743 if (c2.eq.'n'.and.c3.eq.'t') then
01744 c
01745 c INT: Integrate second array with respect to the first.
01746 c
01747 call sdecode(input(istart:nin),3,iarg,*1001)
01748 c
01749 if (iarg(1).eq.0) then
01750 c
01751 c Default is y(x) --> y.
01752 c
01753 iarg(1) = 1
01754 iarg(2) = 2
01755 else if (iarg(2).le.0) then
01756 if (iarg(1).eq.1) then
01757 iarg(2) = 2
01758 else
01759 iarg(2) = 1
01760 end if
01761 end if
01762 c
01763 if (iarg(3).le.0) iarg(3) = iarg(2)
01764 c
01765 if (narr(iarg(1)).le.0) then
01766 if (iprompt.eq.1) then
01767 call devoff
01768 write(6,*)'No points !'
01769 end if
01770 go to 1001
01771 end if
01772 c
01773 call integrate(arr(1,iarg(1)),arr(1,iarg(2)),
01774 & arr(1,iarg(3)),narr(iarg(1)),
01775 & iprompt,*1001)
01776 c
01777 write(6,*)' Integral = ',arr(narr(iarg(1)),iarg(3))
01778 c
01779 else if (c2.eq.'c') then
01780 c
01781 c IC: Allow/disallow comments in input line (smart input only).
01782 c
01783 icomment = 1 - icomment
01784 c
01785 if (icomment.ne.0) then
01786 c
01787 if (istart.gt.nin) then
01788 c
01789 c Default is '%'
01790 c
01791 comment = '%'
01792 else
01793 c
01794 c Use first nonblank character as comment indicator.
01795 c
01796 comment = ' '
01797 do i = istart,nin
01798 if (comment.eq.' '.and.input(i:i).gt.' ')
01799 & comment = input(i:i)
01800 end do
01801 if (comment .eq. ' ') comment = '%'
01802 end if
01803 c
01804 if (iprompt.ne.0)
01805 & write(6,*)'Comment character is "',comment,'"'
01806 c
01807 end if
01808 c
01809 else if (c2.eq.'d') then
01810 c
01811 c ID: Wait for graphic input before continuing.
01812 c (Only wait for devices with a visible display).
01813 c
01814 call devoff
01815 if (gfxin()) then
01816 write(6,'(a)')'Click right-hand mouse button in'
01817 & ' graphics window to continue'
01818 call graphin(r,s)
01819 else if (idev.gt.2.and.idev.ne.5.and.idev.ne.6
01820 & .and.idev.ne.16) then
01821 write(6,'(a)')'Enter <CR> to continue'
01822 read(5,'(a)')c1
01823 end if
01824 c
01825 else if (c2.eq.'m') then
01826 c
01827 c IM: Toggle input mode to accept non-numeric columns.
01828 c
01829 inpmode = 1 - inpmode
01830 if (iprompt.ne.0) write(6,*)'Input mode = ',inpmode,
01831 & ' ('
01832 c
01833 else if (c2.eq.'n'.and.ireplay.eq.0) then
01834 c
01835 c IN: Take input from file.
01836 c
01837 if (istart.le.nin) then
01838 if (inunit.ne.5) close(inunit)
01839 inunit = 7
01840 if (input(istart:istart).eq.'/') then
01841 c
01842 c Absolute path name.
01843 c
01844 datafile = input(istart:nin)
01845 ndata = nin-istart+1
01846 else
01847 c
01848 c Relative path name.
01849 c
01850 datafile = cwd(1:ncwd)
01851 & input(istart:nin)
01852 ndata = nin-istart+1+ncwd+1
01853 end if
01854 c
01855 open(inunit,file=datafile(1:ndata),
01856 & status='old',form='formatted',err=1001)
01857 if (iprompt.eq.1)
01858 & write(6,*)' Reading input from ',
01859 & datafile(1:ndata)
01860 else if (inunit.ne.5) then
01861 close(inunit)
01862 inunit = 5
01863 end if
01864 c
01865 else if (c2.eq.'w') then
01866 c
01867 c IW: Iconify an X window.
01868 c
01869 if (num_win(17).le.0) then
01870 if (iprompt.ne.0) write(6,'(a)')'No X windows!'
01871 else
01872 c
01873 c Iconify an X window.
01874 c
01875 if (istart.le.nin) then
01876 call readiq(input(istart:nin),1,
01877 & iwin,idum,idum,idum,*1001)
01878 c
01879 call iconify_win(iwin)
01880 else
01881 call iconify_all
01882 end if
01883 end if
01884 c
01885 else
01886 c
01887 if (ireplay.eq.0) then
01888 call devoff
01889 if (istart.gt.nin) then
01890 c
01891 c I: Print information on x, y and/or z.
01892 c
01893 call iminmax(x,narr(1),ix1,ix2)
01894 call iminmax(y,narr(2),iy1,iy2)
01895 call iminmax(z,narr(3),iz1,iz2)
01896 call devoff
01897 write(6,196)'x',nx,x(max(1,ix1)),ix1,
01898 & x(max(1,ix2)),ix2,
01899 & xmin,xmax
01900 write(6,196)'y',ny,y(max(1,iy1)),iy1,
01901 & y(max(1,iy2)),iy2,
01902 & ymin,ymax
01903 write(6,196)'z',nz,z(max(1,iz1)),iz1,
01904 & z(max(1,iz2)),iz2
01905 196 format(1x,a1,' (',i6,'): min, max = ',1p,
01906 & 2(e12.4,' (',i6,') '):/
01907 & 14x,'plot:',6x,e12.4,10x,e12.4)
01908 else
01909 c
01910 c Information on specified array.
01911 c
01912 call decode(input(istart:istart),ia,*1001)
01913 call iminmax(arr(1,ia),narr(ia),i1,i2)
01914 write(6,196)char(ia+119),narr(ia),
01915 & arr(max(1,i1),ia),i1,
01916 & arr(max(1,i2),ia),i2
01917 end if
01918 end if
01919 c
01920 end if
01921 c
01922 else if (c1.eq.'j') then
01923 c
01924 c J: Specify point type/connection.
01925 c
01926 call readiq(input(istart:nin),1,
01927 & jth,idum,idum,idum,*1001)
01928 c
01929 else if (c1.eq.'k') then
01930 c
01931 c K: Delete an X-window.
01932 c
01933 if (idev.ne.17) then
01934 if (iprompt.ne.0) write(6,'(a)')'Not using X!'
01935 else
01936 call readiq(input(istart:nin),1,
01937 & iwin,idum,idum,idum,*1001)
01938 call kill_win(iwin)
01939 if (num_win(idev).le.0) idevset = 0
01940 end if
01941 c
01942 else if (c1.eq.'l') then
01943 c
01944 c L: Get/set limits.
01945 c
01946 if (c2.eq.' '.or.c2.eq.'i') then
01947 c
01948 if (istart.gt.nin) then
01949 if (n.le.0) go to 1001
01950 call minmax(x,n,xmin,xmax)
01951 call minmax(y,n,ymin,ymax)
01952 else
01953 call gettokens(input(istart:nin),token,nt)
01954 if (n.le.0.) then
01955 xlo = 0.
01956 xhi = 0.
01957 ylo = 0.
01958 yhi = 0.
01959 else
01960 call minmax(x,n,xlo,xhi)
01961 call minmax(y,n,ylo,yhi)
01962 end if
01963 c
01964 if (nt.eq.1.and.token(1)(1:1).eq.'+') then
01965 c
01966 c Same limits on both axes, +/- L.
01967 c
01968 call readrtoken(token(1),xmax,xhi)
01969 xmin = -xmax
01970 ymin = xmin
01971 ymax = xmax
01972 else
01973 if (nt.gt.0) call readrtoken(token(1),xmin,xlo)
01974 if (nt.gt.1) call readrtoken(token(2),xmax,xhi)
01975 if (nt.gt.2) call readrtoken(token(3),ymin,ylo)
01976 if (nt.gt.3) call readrtoken(token(4),ymax,yhi)
01977 end if
01978 end if
01979 nzoom = 0
01980 c
01981 else if (c2.eq.'a') then
01982 c
01983 c LA: Add a label.
01984 c
01985 if (istart.gt.nin.and.nstring.le.0) go to 1001
01986 c
01987 call strpos(.5,0.)
01988 if (idevset.eq.0) call setup(' ','la')
01989 call devon
01990 if (istart.le.nin) then
01991 c
01992 c Use the specified label.
01993 c
01994 nlabel = nin-istart+1
01995 label(1:nlabel) = input(istart:nin)
01996 c
01997 else if (nlabelsto.gt.0) then
01998 c
01999 c Use the last label.
02000 c
02001 nlabel = nlabelsto
02002 label(1:nlabel) = labelsto(1:nlabelsto)
02003 c
02004 else
02005 c
02006 c Just use the contents of the current string.
02007 c
02008 nlabel = nstring
02009 label(1:nlabel) = stringsto(1:nstring)
02010 c
02011 end if
02012 c
02013 c Save the label, for future use.
02014 c
02015 nlabelsto = nlabel
02016 labelsto(1:nlabelsto) = label(1:nlabel)
02017 c
02018 c Check for font modifications:
02019 c
02020 ntmp = nlabel
02021 tmp(1:ntmp)=label(1:nlabel)
02022 if (iplain.eq.1) call plain_sim(tmp, ntmp)
02023 c
02024 call simbol(.5*xlen,ylen+offlabel*hs,hs,
02025 & tmp(1:ntmp)
02026 call clrstr
02027 c
02028 else if (c2.eq.'o') then
02029 c
02030 if (c3.eq.'o') then
02031 c
02032 c LOOP: Loop over the rest of the line (after the next ";").
02033 c
02034 loop1 = 0
02035 loop2 = 0
02036 linc = 1
02037 c
02038 if (istart.le.nin) then
02039 call readiq(input(istart:nin),3,
02040 & loop1,loop2,linc,idum,*1001)
02041 c
02042 if (loop1.gt.0.and.loop2.le.0) then
02043 c
02044 c Special syntax:
02045 c
02046 loop2 = loop1
02047 loop1 = 1
02048 end if
02049 c
02050 if (loop1.le.0) loop1 = 1
02051 if (loop2.le.0) loop2 = 1000000
02052 else
02053 loop1 = 1
02054 loop2 = 1000000
02055 end if
02056 c
02057 if (loop1.gt.0) then
02058 c
02059 nlstring = nl - iscolon
02060 loopstring(1:nlstring) = line(iscolon+1:nl)
02061 iscolon = nl + 1
02062 c
02063 if (loop1.le.loop2) then
02064 linc = abs(linc)
02065 else
02066 linc = -abs(linc)
02067 end if
02068 c
02069 loop = loop1 - linc
02070 c
02071 end if
02072 c
02073 else
02074 c
02075 c LO: Label vertical offset.
02076 c
02077 call readrq(input(istart:nin),1,
02078 & offlabel,dum,dum,dum,*1001)
02079 c
02080 end if
02081 c
02082 else if (c2.eq.'=') then
02083 c
02084 c L=: Subdivision of the plotting area into quarters,
02085 c according to the loop counter.
02086 c
02087 c First flush the box stack, if any.
02088 c
02089 if (nbox.gt.0) then
02090 write(temp,'(i4)')nbox
02091 nt = 4
02092 if (c2.eq.'0') then
02093 c
02094 c (Necessary to make sure the screen is cleared.)
02095 c
02096 temp(5:6) = ' 1'
02097 nt = 6
02098 end if
02099 call popbox(temp,nt,ierbox,xbox,ybox,bscale,
02100 & nbox,*1001)
02101 end if
02102 c
02103 ib = (loop - loop1) / linc + 1
02104 do while (ib.gt.4)
02105 ib = ib - 4
02106 end do
02107 c
02108 c Choose and initialize a new output area.
02109 c
02110 write(temp(1:2),'(''='',i1)')ib
02111 call newbox(temp,2,ierbox,*1001)
02112 c
02113 else if (c2.eq.'c') then
02114 c
02115 c LC: Set color from loop counter.
02116 c
02117 ic = loop
02118 if (ncolors*(ic/ncolors).eq.ic) ic = ic + 1
02119 c
02120 icsave = icolor
02121 icolor = ic
02122 call color(icolor)
02123 c
02124 else if (c2.eq.'n'.and.c3.ne.'x'.and.c3.ne.'y'
02125 & .and.c3.ne.'z') then
02126 c
02127 c LN: Set number of n-gon sides from loop counter.
02128 c
02129 jsym = loop
02130 plot_symbol = ' '
02131 do while (jsym.gt.20)
02132 jsym = jsym - 20
02133 end do
02134 c
02135 else if (c2.eq.'p') then
02136 c
02137 c LP: Print loop counter.
02138 c
02139 write(6,*)'Loop = ',loop
02140 c
02141 else if (c2.eq.'w') then
02142 c
02143 c LW: Set weight from loop counter.
02144 c
02145 iwt = 10*(loop-1)
02146 do while (iwt.gt.50)
02147 iwt = iwt - 50
02148 end do
02149 c
02150 if (iwt.le.0) iwt = 1
02151 c
02152 iwtsto = iweight
02153 iweight = iwt
02154 call weight(iweight)
02155 c
02156 else if (c2.eq.'y') then
02157 c
02158 c LY: Read the y array from a column specified by
02159 c the loop counter. Exit the loop on error.
02160 c
02161 if (iopen.eq.0) then
02162 if (loop.gt.0) loop = 0
02163 if (iprompt.eq.1) then
02164 call devoff
02165 write(6,*)'No file open'
02166 go to 10
02167 else
02168 go to 1001
02169 end if
02170 end if
02171 c
02172 iy = loop
02173 c
02174 call readcols(10,nhead,nrange,iy,iy,x,y,z,ny,nmax,
02175 & c2,0,iprompt,*1001)
02176 c
02177 else if (c2.eq.'g'.or.c2.eq.'n') then
02178 c
02179 c LG(N): Logarithms.
02180 c
02181 call decode(c3,ia,*1001)
02182 nerr=0
02183 do 200 i=1,narr(ia)
02184 s=arr(i,ia)
02185 if (s.le.0.) then
02186 nerr=nerr+1
02187 arr(i,ia)= -50.
02188 else
02189 if (c2.eq.'n') then
02190 arr(i,ia)=log(arr(i,ia))
02191 else
02192 arr(i,ia)=log10(arr(i,ia))
02193 end if
02194 end if
02195 200 continue
02196 if (nerr.gt.0) then
02197 if (iprompt.eq.1) then
02198 call devoff
02199 write(6,'(i5,'' error(s)'')')nerr
02200 end if
02201 end if
02202 c
02203 else
02204 go to 1001
02205 end if
02206 c
02207 else if (c1.eq.'m') then
02208 c
02209 if (c2.eq.'o') then
02210 c
02211 c MO: Specify plot modes.
02212 c
02213 call readiq(input(istart:nin),2,
02214 & mx,my,idum,idum,*1001)
02215 modex = mx
02216 modey = my
02217 if (my.eq.0) modey = modex
02218 c
02219 else if (c2.eq.'v') then
02220 c
02221 c MV: Move an array.
02222 c
02223 ibl=1
02224 narg=0
02225 do 250 i=istart,nin
02226 if (input(i:i).eq.' '.or.input(i:i).eq.',') then
02227 ibl=1
02228 else
02229 if (ibl.eq.1) then
02230 narg=narg+1
02231 call decode(input(i:i),iarg(narg),*1001)
02232 if (narg.eq.2) then
02233 if (narr(iarg(1)).le.0) go to 1001
02234 do 240 ii=1,narr(iarg(1))
02235 arr(ii,iarg(2))=arr(ii,iarg(1))
02236 240 continue
02237 narr(iarg(2)) = narr(iarg(1))
02238 go to 251
02239 end if
02240 ibl=0
02241 end if
02242 end if
02243 250 continue
02244 251 continue
02245 c
02246 else if (c2.eq.' '.or.c2.eq.'a') then
02247 c
02248 c M: Move to the specified point.
02249 c
02250 if (nin.lt.istart) then
02251 rloc=rgin
02252 sloc=sgin
02253 else
02254 call readrq(input(istart:nin),2,
02255 & rloc,sloc,dum,dum,*1001)
02256 c
02257 if (c2.ne.'a') then
02258 if (ibox.ne.0)
02259 & call fr inches(rloc,sloc,rloc,sloc)
02260 else
02261 rloc = rloc - ro
02262 sloc = sloc - so
02263 end if
02264 end if
02265 end if
02266 c
02267 else if (c1.eq.'n') then
02268 c
02269 if (c2.eq.'c') then
02270 c
02271 c NC: Toggle use of comma as delimiter.
02272 c Default value of nsep is 3, make it 2
02273 c to allow commas in get_token.
02274 c
02275 nsep = 5 - nsep
02276 c
02277 if (iprompt.ne.0) then
02278 if (nsep.eq.2) then
02279 write(6,*)'Commas ignored in input data'
02280 else
02281 write(6,*)'Commas accepted as delimiters'
02282 end if
02283 end if
02284 else if (c2.eq.'p') then
02285 c
02286 c NP: Plot a polygon at the specified point. Size, number
02287 c of sides, and fill color are the same as for mline.
02288 c
02289 if (nin.lt.istart) then
02290 rloc=rgin
02291 sloc=sgin
02292 else
02293 call readrq(input(istart:nin),2,
02294 & rloc,sloc,dum,dum,*1001)
02295 if (ibox.ne.0) call fr inches(rloc,sloc,rloc,sloc)
02296 end if
02297 c
02298 call ngon(rloc,sloc,.5*hp,jsym,0.)
02299 c
02300 else if (c2.eq.'x'.or.c2.eq.'y'.or.c2.eq.'z') then
02301 c
02302 c NX(Y,Z): Explicitly set narr.
02303 c NXY: set nx and ny to the same value
02304 c NXYZ: set nx, ny, and nz to the same value
02305 c
02306 call readiq(input(istart:nin),1,
02307 & newn,idum,idum,idum,*1001)
02308 c
02309 if (c2.eq.'x'.and.c3.eq.'y') then
02310 nn = 2
02311 if (c4.eq.'z') nn = 3
02312 do ia=1,nn
02313 narr(ia) = newn
02314 end do
02315 else
02316 call decode(c2,ia,*1001)
02317 narr(ia) = newn
02318 end if
02319 c
02320 else
02321 c
02322 c N: Set polygon style.
02323 c
02324 if (istart.le.nin) then
02325 c
02326 c n s ==> plot symbols at each point.
02327 c n # ==> set jsym (polygons, spokes, etc.)
02328 c
02329 if ((input(istart:istart).lt.'0'
02330 $ .or.input(istart:istart).gt.'9')
02331 $ .and.input(istart:istart).ne.'-') then
02332 plot_symbol = input(istart:istart)
02333 else
02334 plot_symbol = ' '
02335 call readiq(input(istart:nin),1,
02336 & jsym,idum,idum,idum,*1001)
02337 if (jsym.ge.0) then
02338 call unsetstars
02339 else
02340 call setstars
02341 end if
02342 end if
02343 end if
02344 end if
02345 c
02346 else if (c1.eq.'o') then
02347 c
02348 if (c2.ne.'-') then
02349 c
02350 if (c2.eq.'f') then
02351 c
02352 c OF: set data delsets.
02353 c
02354 delx = 0.
02355 dely = 0.
02356 delz = 0.
02357 call readrq(input(istart:nin),3,
02358 & delx,dely,delz,dum,*1001)
02359 c
02360 else
02361 c
02362 c O: Set string offset.
02363 c
02364 call readrq(input(istart:nin),2,
02365 & fx,fy,dum,dum,*1001)
02366 c
02367 if (ierr.ne.0) then
02368 call clrstr
02369 else
02370 offxsave = offx
02371 offysave = offy
02372 offx = fx
02373 offy = fy
02374 call strpos(offx,offy)
02375 end if
02376 end if
02377 c
02378 else
02379 dum = offxsave
02380 offx = offxsave
02381 offxsave = dum
02382 dum = offysave
02383 offy = offysave
02384 offysave = dum
02385 call strpos(offx,offy)
02386 end if
02387 c
02388 else if (c1.eq.'p') then
02389 c
02390 if (c2.eq.'a') then
02391 c
02392 c PA: New page.
02393 c
02394 call devon
02395 call newpage
02396 c
02397 else if (c2.eq.'f') then
02398 c
02399 c PF: Set polygon fill index.
02400 c
02401 call readiq(input(istart:nin),1,
02402 & i1,idum,idum,idum,*1001)
02403 c
02404 if (i1.ge.0) then
02405 call setfill(i1)
02406 else
02407 call unsetfill
02408 end if
02409 c
02410 else if (c2.eq.'o') then
02411 c
02412 c PO: Plot points only (same as "j -1", but more obvious)
02413 c
02414 jth = -1
02415 c
02416 else if (c2.eq.'r') then
02417 c
02418 c PR(C): Print current Postscript and (optionally) close
02419 c PS output.
02420 c
02421 if (idev.eq.16) then
02422 if (c3.eq.'c') then
02423 call psquit(2)
02424 c
02425 c In this case, we have to reinitialize the graphics
02426 c device -- either X or from scratch.
02427 c
02428 if (num_win(17).gt.0) then
02429 c
02430 c Restore the last-used X-window.
02431 c
02432 if (iprompt.gt.0) write(6,'(a)')
02433 $ 'Reverting to X-window output.'
02434 c
02435 idev = 17
02436 iwin = curr_win()
02437 no_new_xwin = iwin
02438 call setup('x','psquit')
02439 no_new_xwin = -1
02440 call set_win(iwin, ierr)
02441 else
02442 idevset = 0
02443 call setup(' ', 'psquit')
02444 end if
02445 else
02446 call psquit(1)
02447 end if
02448 end if
02449 c
02450 else if (c2.eq.'s') then
02451 c
02452 if (c3.eq.'c') then
02453 c
02454 c PSC: Toggle use of color in PostScript:
02455 c
02456 call set ps color
02457 c
02458 if (iprompt.eq.1) then
02459 call get ps color(ipsc)
02460 if (ipsc.eq.0) then
02461 write(6,*)'Using ',ncolors,
02462 & '-greyscale PostScript'
02463 else
02464 write(6,*)'Using ',ncolors,
02465 & '-color PostScript'
02466 end if
02467 end if
02468 c
02469 else if (c3.eq.'q') then
02470
02471 c Very like 'prc', but don't attempt to repoen
02472 c a graphics device of none is left.
02473
02474 if (idev.eq.16) then
02475 call psquit(2)
02476 c
02477 c In this case, we have to reinitialize the graphics
02478 c device -- either X or from scratch.
02479 c
02480 if (num_win(17).gt.0) then
02481 c
02482 c Restore the last-used X-window.
02483 c
02484 if (iprompt.gt.0) write(6,'(a)')
02485 $ 'Reverting to X-window output.'
02486 c
02487 idev = 17
02488 iwin = curr_win()
02489 no_new_xwin = iwin
02490 call setup('x','psquit')
02491 no_new_xwin = -1
02492 call set_win(iwin, ierr)
02493 else
02494 idevset = 0
02495 end if
02496 end if
02497
02498 else if (c3.eq.'r') then
02499
02500 c PSR: Force rewriting of long Postscript files
02501 c to place BoundingBox at start.
02502
02503 call set ps write
02504
02505 else
02506 c
02507 c PS: Replace y(x) by its power spectrum, x by frequency.
02508 c Assume that the data are evenly spaced.
02509 c
02510 call powerspectrum(x,y,nx,iprompt)
02511 ny = nx
02512 c
02513 end if
02514 c
02515 else if (c2.eq.'w'.and.c3.eq.'d') then
02516 c
02517 c PWD: UNIX "pwd" lookalike.
02518 c
02519 call mygetenv('PWD',pwd)
02520 do i=len(pwd),1,-1
02521 if (pwd(i:i).gt.' ') go to 300
02522 end do
02523 i = 1
02524 pwd(1:1) = '?'
02525 300 write(6,*)cwd(1:ncwd),' (. = ',pwd(1:i),')'
02526 c
02527 else if (c2.eq.'z') then
02528 c
02529 c PZ: Plot y(x), clipped according to z.
02530 c
02531 if (n.le.0) then
02532 if (iprompt.eq.1) write(6,*)'No points !'
02533 go to 1001
02534 end if
02535 c
02536 if (ibox.le.0) then
02537 if (iprompt.eq.1) write(6,*)'No box !'
02538 go to 1001
02539 end if
02540 c
02541 call xyzplot(input,istart,nin,
02542 & x,y,z,n,jth,jsym,plot_symbol,hp,*1001)
02543 c
02544 else
02545 c
02546 c P: Plot y(x).
02547 c
02548 if (n.le.0) then
02549 if (iprompt.eq.1) write(6,*)'No points !'
02550 go to 1001
02551 end if
02552 c
02553 if (ibox.le.0) then
02554 if (iprompt.eq.1) write(6,*)'No box !'
02555 go to 1001
02556 end if
02557 c
02558 if (c2.eq.'c') then
02559 call xyplotc(input,istart,nin,x,y,z,n,
02560 & itype,jth,jsym,plot_symbol,hp,*1001)
02561 else
02562 call xyplot(input,istart,nin,x,y,z,n,
02563 & itype,jth,jsym,plot_symbol,hp,*1001)
02564 end if
02565 c
02566 end if
02567 c
02568 else if (c1.eq.'q') then
02569 c
02570 if (c2.eq.'u') then
02571 c
02572 c QU(IET): suppress most output (like '*' toggle).
02573 c
02574 iprompt = 0
02575 c
02576 else
02577 c
02578 c Q: Exit graphics/mcdraw.
02579 c
02580 call devoff
02581 if (c2.ne.'1') then
02582 call mcquit
02583 else
02584 call mcquit1
02585 end if
02586 c
02587 if (c2.ne.'c') go to 99999
02588 idevset = 0
02589 c
02590 end if
02591 c
02592 else if (c1.eq.'r') then
02593 c
02594 if (c2.eq.'a') then
02595 c
02596 c RA: Put a ramp from 1 to n in the specified array.
02597 c
02598 call sdecode(input(istart:nin),2,iarg,*1001)
02599 if (iarg(1).le.0) iarg(1) = 1
02600 c
02601 if (narr(iarg(1)).le.0.and.iarg(2).le.0) then
02602 if (iprompt.eq.1) then
02603 write(6,*)'Array length unknown.'
02604 go to 10
02605 else
02606 go to 1001
02607 end if
02608 end if
02609 c
02610 c Specifying a second argument sets the value of narr.
02611 c
02612 if (iarg(2).gt.0) narr(iarg(1)) = iarg(2)
02613 c
02614 do 340 i=1,narr(iarg(1))
02615 arr(i,iarg(1)) = i
02616 340 continue
02617 c
02618 else if (c2.eq.'n') then
02619 c
02620 c RN: Put random numbers in the specified array.
02621 c
02622 call sdecode(input(istart:nin),2,iarg,*1001)
02623 if (iarg(1).le.0) iarg(1) = 1
02624 c
02625 if (narr(iarg(1)).le.0.and.iarg(2).le.0) then
02626 if (iprompt.eq.1) then
02627 write(6,*)'Array length unknown.'
02628 go to 10
02629 else
02630 go to 1001
02631 end if
02632 end if
02633 c
02634 c Specifying a second argument sets the value of n.
02635 c
02636 if (iarg(2).gt.0) narr(iarg(1)) = iarg(2)
02637 c
02638 do 341 i=1,narr(iarg(1))
02639 arr(i,iarg(1)) = random(0)
02640 341 continue
02641 c
02642 else if (c2.eq.'e') then
02643 c
02644 if (c3.eq.'b') then
02645 c
02646 c REB: Rebin the specified array, via a C routine
02647 c to allocate space.
02648 c
02649 call crebin(input(istart:nin),arr,nmax,narr,
02650 & istat,iprompt)
02651 if (istat.ne.0) go to 1001
02652 c
02653 else if (c3.eq.'s') then
02654 c
02655 c RES: Reset most plotting parameters to their initial states.
02656 c Note that the device and the plot offsets are untouched.
02657 c
02658 xmin = 0.
02659 xmax = 1.
02660 modex = 2
02661 xttl = ' '
02662 ymin = 0.
02663 ymax = 1.
02664 modey = 2
02665 yttl = ' '
02666 c
02667 nzoom = 0
02668 c
02669 close(10)
02670 iopen = 0
02671 nx = 0
02672 ny = 0
02673 nz = 0
02674 nhead0 = 0
02675 nhead = 0
02676 c
02677 itype = 0
02678 ibox = 0
02679 jth = 0
02680 jsym = 0
02681 plot_symbol = ' '
02682 npl = 1
02683 c
02684 rgin = 0.
02685 sgin = 0.
02686 nstring = 0
02687 icolor = 1
02688 call color(icolor)
02689 c
02690 call newbox('=-0',3,ierbox,*1001)
02691 hp = .1
02692 hn = .2
02693 hs = .25
02694 call sethts(hs,hn)
02695 iplain = 0
02696 call setpln
02697 call nobounds
02698 c
02699 offlabel = .5
02700 rloc = 0.
02701 sloc = 0.
02702 c
02703 cwd = '.'
02704 ncwd = 1
02705 c
02706 else if (c3.eq.'p') then
02707 c
02708 c REP: Replay commands, with modifications and omissions.
02709 c
02710 if (ireplay.eq.0) then
02711 if (istart.le.nin) then
02712 call rdecode(input(istart:nin),nhist,
02713 & i1,i2,*1001)
02714 i1=max(1,min(nhist,i1))
02715 i2=max(i1,min(nhist,i2))
02716 else
02717 i1=1
02718 i2=nhist
02719 end if
02720 ireplay = i1
02721 jreplay = i2
02722 iscolon = nl + 1
02723 end if
02724 end if
02725 c
02726 else if (c2.eq.'p') then
02727 c
02728 c RP: Print register.
02729 c
02730 write(6,*)'Register = ',register
02731 c
02732 else if (c2.eq.'r') then
02733 c
02734 c RR: Specify read ranges (i1 to i2, after header).
02735 c
02736 call gettokens(input(istart:nin),token,nt)
02737 i1 = 1
02738 if (nt.gt.0) call readitoken(token(1),i1,1)
02739 i2 = 10000000
02740 if (nt.gt.1) call readitoken(token(2),i2,10000000)
02741 nhead = nhead0 + i1 - 1
02742 nrange = i2 - i1 + 1
02743 c
02744 else if (c2.eq.'s') then
02745 c
02746 c RS: Set register.
02747 c
02748 call readrq(input(istart:nin),1,
02749 & register,dum,dum,dum,*1001)
02750 c
02751 else if (c2.eq.'x'.or.c2.eq.'y'.or.c2.eq.'z') then
02752 c
02753 c RX,Y,Z: Set register from x,y,z.
02754 c
02755 call readiq(input(istart:nin),1,
02756 & ireg,idum,idum,idum,*1001)
02757 c
02758 iarr = ichar(c2) - ichar('x') + 1
02759 register = arr(max(1,min(n,ireg)),iarr)
02760 c
02761 end if
02762 c
02763 else if (c1.eq.'s') then
02764 c
02765 if (c2.eq.' '.or.(c2.eq.'t'.and.c3.eq.'r')) then
02766 c
02767 c S: Plot string at current location.
02768 c
02769 if (istart.le.nin) then
02770 nstring=nin-istart+1
02771 stringsto(1:nstring)=input(istart:nin)
02772 c
02773 c Check for font modifications:
02774 c
02775 ntmp = nstring
02776 tmp(1:ntmp)=stringsto(1:nstring)
02777 if (iplain.eq.1) call plain_sim(tmp, ntmp)
02778 c
02779 call boxsim(rloc,sloc,hs,
02780 & tmp(1:ntmp)//'%%',angle,999)
02781 c
02782 else if (nstring.gt.0) then
02783 c
02784 c Check for font modifications:
02785 c
02786 ntmp = nstring
02787 tmp(1:ntmp)=stringsto(1:nstring)
02788 if (iplain.eq.1) call plain_sim(tmp, ntmp)
02789 c
02790 call boxsim(rloc,sloc,hs,
02791 & tmp(1:ntmp)//'%%',angle,999)
02792 end if
02793 c
02794 else if (c2.eq.'a') then
02795 c
02796 c SA: Save x, y and z in specified file.
02797 c
02798 if (max(nx,ny,nz).le.0) go to 1001
02799 c
02800 open(1,file=input(istart:nin),status='new',
02801 & form='formatted',iostat=io)
02802 if (io.ne.0) then
02803 write(6,*)'Error opening new ',input(istart:nin)
02804 go to 1001
02805 end if
02806 do i=1,max(nx,ny,nz)
02807 if (i.gt.nx) x(i) = x(nx)
02808 if (i.gt.ny) y(i) = y(ny)
02809 if (i.gt.nz) z(i) = z(nz)
02810 write(1,*)i,x(i),y(i),z(i)
02811 end do
02812 close(1)
02813 c
02814 else if (c2.eq.'b') then
02815 c
02816 c SB: Specify string-box parameters.
02817 c SB?: Print string-box parameters.
02818 c
02819 if (c3.eq.'?') then
02820 if (iprompt.ne.0) then
02821 call sboxset(ib,ie,fr)
02822 write(6,'(a,i1,a,i1,a,f7.3)')
02823 & ' box = ',ib,' erase = ',ie,
02824 & ' fraction = ',fr
02825 end if
02826 else
02827 call readrq(input(istart:nin),3,
02828 & xib,xie,fr,dum,*1001)
02829 ib = nint(xib)
02830 if (ib.ne.0) ib = 1
02831 ie = nint(xie)
02832 if (ie.ne.0) ie = 1
02833 if (fr.lt.0.) fr = 0.
02834 call sboxset(ib,ie,fr)
02835 end if
02836 c
02837 else if (c2.eq.'c') then
02838 c
02839 c SC: set data scaling.
02840 c
02841 facx = 1.
02842 facy = 1.
02843 facz = 1.
02844 call readrq(input(istart:nin),3,
02845 & facx,facy,facz,dum,*1001)
02846 c
02847 else if (c2.eq.'l') then
02848 c
02849 c SL: Sleep for a specified number of seconds
02850 c (useful for pausing in loops).
02851 c
02852 call readiq(input(istart:nin),1,
02853 & isl,idum,idum,idum,*1001)
02854 call uwait(1000000*isl)
02855 c
02856 else if (c2.eq.'m') then
02857 if (c3.eq.'o') then
02858 c
02859 c SMO: Smooth y --> z.
02860 c
02861 if (n.le.0.or.istart.gt.nin) go to 1001
02862 c
02863 call readrq(input(istart:nin),3,
02864 & dtsmooth,xioption,xiwindow,dum,*1001)
02865 c
02866 ioption = nint(xioption)
02867 iwindow = nint(xiwindow)
02868 call smooth(x,y,z,n,dtsmooth,ioption,iwindow)
02869 nz = n
02870 else
02871 c
02872 c SM: Make box smaller.
02873 c
02874 red = REDUCE
02875 call readrq(input(istart:nin),1,
02876 & red,dum,dum,dum,*1001)
02877 xlen = red*xlen
02878 ylen = red*ylen
02879 end if
02880 c
02881 else if (c2.eq.'o') then
02882 c
02883 if (c3.eq.' '.or.c3.eq.'-') then
02884 c
02885 c SO: Sort an array.
02886 c
02887 call sdecode(input(istart:nin),1,iarg,*1001)
02888 if (iarg(1).le.0) iarg(1) = 1
02889 if (narr(iarg(1)).le.0) go to 1001
02890 c
02891 if (c3.eq.'1')
02892 & call negate(narr(iarg(1)),arr(1,iarg(1)))
02893 c
02894 call sort(narr(iarg(1)),arr(1,iarg(1)))
02895 c
02896 if (c3.eq.'1')
02897 & call negate(narr(iarg(1)),arr(1,iarg(1)))
02898 c
02899 else if (c3.eq.'2') then
02900 c
02901 c SO2: Sort an array, carrying another along with it.
02902 c
02903 call sdecode(input(istart:nin),2,iarg,*1001)
02904 if (iarg(1).le.0) iarg(1) = 1
02905 if (narr(iarg(1)).le.0) go to 1001
02906 if (iarg(2).le.0) iarg(2) = iarg(1)
02907 c
02908 call sort2(narr(iarg(1)),arr(1,iarg(1)),
02909 & arr(1,iarg(2)))
02910 c
02911 else
02912 go to 1001
02913 end if
02914 c
02915 else if (c2.eq.'s') then
02916 c
02917 c SS: Plot an X/SUN/PS string at the current point.
02918 c
02919 if (istart.le.nin) then
02920 call symbl(rloc,sloc,hs,
02921 & input(istart:nin)//'%%',angle,999)
02922 nstring=nin-istart+1
02923 stringsto(1:nstring)=input(istart:nin)
02924 else if (nstring.gt.0) then
02925 call symbl(rloc,sloc,hs,
02926 & stringsto(1:nstring)//'%%',angle,999)
02927 end if
02928 c
02929 else if (c2.eq.'t') then
02930 c
02931 c STAT: Dump status of mcdraw.
02932 c
02933 if (iprompt.eq.1) then
02934 c
02935 call devoff
02936 c
02937 c Directory, etc:
02938 c
02939 write(6,'(/a)')' working directory = "'
02940 & cwd(1:ncwd)
02941 call mygetenv('PWD',pwd)
02942 do i=len(pwd),1,-1
02943 if (pwd(i:i).gt.' ') go to 400
02944 end do
02945 i = 1
02946 pwd(1:1) = '?'
02947 400 write(6,*)' (. = ',pwd(1:i),')'
02948
02949
02950 write(6,'(a)')' data file name = "'//
02951 & datafile(1:ndata)//'"'
02952 c
02953 c Data input.
02954 c
02955 write(6,'(a,i1,a)')' data input mode = ',
02956 & inpmode,' ('
02957
02958 if (inpmode.eq.1) then
02959 if (nsep.eq.2) then
02960 write(6,'(a)')
02961 & ' commas ignored in input data'
02962 else
02963 write(6,'(a)')' commas accepted as'
02964 & ' delimiters in input data'
02965 end if
02966 if (icomment.ne.0)
02967 & write(6,'(a)')
02968 & ' input comment character is "'//
02969 & comment//'"'
02970 end if
02971 c
02972 c Graphics device:
02973 c
02974 nd = len(device)
02975 do while (nd.gt.0.and.device(nd:nd).le.' ')
02976 nd = nd - 1
02977 end do
02978 if (nd.le.0) nd = 1
02979
02980 write(6,'(/a)')' graphics device = "'//
02981 & device(1:nd)//'"'
02982 c
02983 write(6,'(a,f4.1,a,f4.1,a,i4,a,i4)')
02984 & ' xsize = ',xsize,' ysize = ',ysize,
02985 & ' nxpix = ',nxpix,' nypix = ',nypix
02986 write(6,'(a,f5.2,a,f5.2)')
02987 & ' device aspect ratio = ',aspect,
02988 & ' mcdraw aspect ratio = ',aspect1
02989 c
02990 write(6,'(/a,i4,a,i4)')' colors = ',ncolors,
02991 & ' current color = ',icolor
02992 if (idev.eq.15.or.idev.eq.17) then
02993 ncmap = 0
02994 do i=len(colormapfile),1,-1
02995 if (colormapfile(i:i).gt.' '
02996 $ .and.ncmap.eq.0) then
02997 ncmap = i
02998 write(6,'(a)')' color map file = '
02999 $
03000 end if
03001 end do
03002 end if
03003 c
03004 nwin = 0
03005 do id = 1,20
03006 nwin = nwin + num_win(id)
03007 end do
03008 write(6,'(a,i5,a,i5,a)')
03009 $ ' current window = ',curr_win(),
03010 $ ' (total number = ',nwin,')'
03011 write(6,'(a,l1)')' audio = ',audio
03012 c
03013 c Plotting:
03014 c
03015 write(6,'(/a,f6.2,a,f6.2,a)')
03016 & ' box origin = (',ro,', ',so,')'
03017 write(6,'(a,f5.2,a,f5.2,a,i2,a,i2)')
03018 & ' xlen = ',xlen,' ylen = ',ylen,
03019 & ' modex = ',modex,' modey = ',modey
03020 write(6,'(3(a,f7.3),a,i1)')
03021 & ' hs = ',hs,' hn = ',hn,' hp = ',hp,
03022 & ' plain = ',iplain
03023
03024 write(6,'(3(a,i5),a)')' weight = ',iweight,
03025 & ' jth = ',jth,
03026 $ ' ngons: ',jsym,' '
03027 write(6,'(a,4i4)')' pattern: ',ipat
03028 c
03029 write(6,*)
03030 write(6,'(3(a,i2)/)')' ix = ',ix,' iy = ',iy,
03031 & ' iz = ',iz
03032 call iminmax(x,narr(1),ix1,ix2)
03033 call iminmax(y,narr(2),iy1,iy2)
03034 call iminmax(z,narr(3),iz1,iz2)
03035 write(6,196)'x',nx,x(max(1,ix1)),ix1,
03036 & x(max(1,ix2)),ix2,
03037 & xmin,xmax
03038 write(6,196)'y',ny,y(max(1,iy1)),iy1,
03039 & y(max(1,iy2)),iy2,
03040 & ymin,ymax
03041 write(6,196)'z',nz,z(max(1,iz1)),iz1,
03042 & z(max(1,iz2)),iz2
03043 c
03044 c Miscellaneous:
03045 c
03046 write(6,'(/a,5i3)')' ierbox = ',ierbox
03047 if (nbox.gt.0) write(6,'(a,3(a,f5.2))')' box: ',
03048 & 'xbox = ',xbox(nbox),
03049 & ' ybox = ',ybox(nbox),
03050 & ' scale = ',bscale(nbox)
03051 c
03052 write(6,'(a,f5.2)')' label = "'//label(1:nlabel)//
03053 & '" offset = ',offlabel
03054 write(6,'(a)')' string = "'//
03055 & stringsto(1:nstring)//'"'
03056 write(6,'(a,f7.2,a,2f5.2)')' angle = ',angle,
03057 & ' offsets: ',offx,offy
03058 write(6,'(a,1p,e14.6)')' register = ',register
03059 c
03060 write(6,*)
03061 c
03062 end if
03063 c
03064 else if (c2.eq.'w') then
03065 c
03066 c SW: Swap two arrays.
03067 c
03068 if (n.le.0)go to 1001
03069 call sdecode(input(istart:nin),2,iarg,*1001)
03070 if (iarg(1).le.0) iarg(1) = 1
03071 if (iarg(2).le.0) iarg(2) = 2
03072 c
03073 call swap(arr(1,iarg(1)),arr(1,iarg(2)),n)
03074 c
03075 else if (c2.eq.'y') then
03076 c
03077 c SY: Execute a UNIX command in the current ("pwd") directory..
03078 c
03079 if (ireplay.eq.0.and.istart.le.nin) then
03080 iret = mysystem('cd '
03081 & input(istart:nin)
03082 if (iprompt.eq.1) write(6,*)'Return status = ',iret
03083 end if
03084 c
03085 else
03086 c
03087 c S+(-,*,/): Perform scalar arithmetic on an array.
03088 c
03089 call sarith(input,istart,nin,arr,nmax,narr,register,
03090 & iprompt,*1001)
03091 c
03092 end if
03093 c
03094 else if (c1.eq.'t') then
03095 c
03096 if (c2.eq.'x'.or.c2.eq.'y'.or.c2.eq.'z') then
03097 c
03098 c TX,Y,Z: Type first few elements of x,y,z.
03099 c
03100 if (istart.le.nin) then
03101 call readiq(input(istart:nin),1,
03102 & ntype,idum,idum,idum,*1001)
03103 else
03104 ntype = 10
03105 end if
03106 c
03107 iarr = ichar(c2) - ichar('x') + 1
03108 call devoff
03109 write(6,'(1p,6e12.4)')(arr(i,iarr),i=1,ntype)
03110 c
03111 else if (c2.eq.'i') then
03112 c
03113 c TI: Specify tick level on frame.
03114 c
03115 call readiq(input(istart:nin),1,
03116 & itik,idum,idum,idum,*1001)
03117 if (itik.ne.2.and.itik.ne.3) itik = 1
03118 call settiks(itik)
03119 c
03120 else if (c2.eq.' ') then
03121 c
03122 c T: Specify line type.
03123 c
03124 if (istart.gt.nin) then
03125 itype = 0
03126 ipat(1) = 0
03127 ipat(2) = 0
03128 ipat(3) = 0
03129 ipat(4) = 0
03130 else
03131 call readiq(input(istart:nin),4,
03132 & i1,i2,i3,i4,*1001)
03133 itype = 1
03134 call setpat(i1,i2,i3,i4)
03135 ipat(1) = i1
03136 ipat(2) = i2
03137 ipat(3) = i3
03138 ipat(4) = i4
03139 end if
03140 end if
03141 c
03142 else if (c1.eq.'u') then
03143 c
03144 c U: Unplot the previous plot (if possible).
03145 c
03146 if (ibox.eq.0) go to 1001
03147 c
03148 call invert
03149 call unplot(x,y,z,n,itype,jth,jsym,plot_symbol,hp)
03150 call invert
03151 c
03152 else if (c1.eq.'v') then
03153 c
03154 if (c2.eq.'l') then
03155 c
03156 c VL: Vertical y-axis label.
03157 c
03158 call getmod(i1,i2,i3,i4,i5)
03159 call setmod(i1,i2,i3,i4,1)
03160 c
03161 else if (c2.eq.' ') then
03162 c
03163 c V: Invert subsequent plot colors.
03164 c
03165 if (idevset.eq.0)call setup(' ','v')
03166 call devon
03167 call invert
03168 c
03169 else
03170 go to 1001
03171 end if
03172 c
03173 else if (c1.eq.'w') then
03174 c
03175 if (c2.eq.'-'.or.c2.eq.' ') then
03176 c
03177 if (c2.eq.'-') then
03178 c
03179 c W-: restore line weight.
03180 c
03181 iwt = iwtsto
03182 else
03183 c
03184 c W: Set line weight.
03185 c
03186 call readiq(input(istart:nin),1,
03187 & iwt,idum,idum,idum,*1001)
03188 c
03189 end if
03190 c
03191 iwtsto = iweight
03192 iweight = iwt
03193 call weight(iweight)
03194 c
03195 else if (c2.eq.'i') then
03196 c
03197 c WI(N): Specify which X window to use.
03198 c
03199 if (idev.ne.17) then
03200 if (num_win(17).le.0) then
03201 if (iprompt.ne.0) write(6,'(a)')'No X windows!'
03202 else
03203 if (istart.gt.nin) then
03204 if (iprompt.ne.0)
03205 $ write(6,'(a)')'X not selected.'
03206 else
03207 c
03208 c Select an existing X window.
03209 c
03210 call readiq(input(istart:nin),1,
03211 & iwin,idum,idum,idum,*1001)
03212 c
03213 no_new_xwin = iwin
03214 call setup('x','win')
03215 no_new_xwin = -1
03216 call set_win(iwin, ierr)
03217 end if
03218 end if
03219 else
03220 if (istart.gt.nin) then
03221 c
03222 c Just print the current window ID.
03223 c
03224 if (iprompt.ne.0) then
03225 iwin = curr_win()
03226 if (iwin.ge.0) then
03227 write(6,'(a,i4)')
03228 $ 'Current X output window is #',iwin
03229 else
03230 write(6,'(a)')'No window open.'
03231 end if
03232 end if
03233 else
03234 call readiq(input(istart:nin),1,
03235 & iwin,idum,idum,idum,*1001)
03236 c
03237 c NOTE: Context switching must be performed here if
03238 c we want different windows/devices to be independent.
03239 c
03240 icurrwin = curr_win()
03241 if (iwin.ne.icurrwin) then
03242 call save_context(idev,icurrwin)
03243 call set_win(iwin, iret)
03244 if (iret.ge.0)
03245 $ call load_context(idev,iwin)
03246 else
03247 call set_win(iwin, iret)
03248 end if
03249 end if
03250 end if
03251 end if
03252 c
03253 else if (c1.eq.'x') then
03254 c
03255 if (c2.eq.' ') then
03256 c
03257 c X: Read the x array.
03258 c
03259 if (iopen.eq.0) then
03260 if (iprompt.eq.1) then
03261 call devoff
03262 write(6,*)'No file open'
03263 go to 10
03264 else
03265 go to 1001
03266 end if
03267 end if
03268 c
03269 call readiq(input(istart:nin),1,
03270 & ix,idum,idum,idum,*1001)
03271 if (ix.le.0)go to 1001
03272 c
03273 call readcols(10,nhead,nrange,ix,ix,x,y,z,nx,nmax,
03274 & c1,0,iprompt,*1001)
03275 c
03276 else if (c2.eq.'l') then
03277 c
03278 c XL: Specify x label.
03279 c
03280 xttl=' '
03281 if (istart.le.nin)xttl=input(istart:nin)
03282 if (c3.eq.'p'.and.ibox.eq.1) call labels(xttl,' ')
03283 c
03284 else if (c2.eq.'o') then
03285 c
03286 c XO: Set x-axis mode (XON, XOFF).
03287 c
03288 if (c3.eq.'f') then
03289 call setxaxis(0)
03290 else if (c3.eq.'n') then
03291 call setxaxis(1)
03292 end if
03293 else if (c2.eq.'w') then
03294 c
03295 c XW: Print current X-window.
03296 c
03297 if (idev.ne.17) then
03298 if (iprompt.ne.0) write(6,'(a)')'Not using X!'
03299 else if (iprompt.ne.0) then
03300 iwin = curr_win()
03301 if (iwin.ge.0) then
03302 write(6,'(a,i4)')
03303 $ 'Current X output window is #',iwin
03304 else
03305 write(6,'(a)')'No window open.'
03306 end if
03307 end if
03308 c
03309 else if (c2.eq.'x') then
03310 c
03311 c XX: Read the x array, without worrying about columns.
03312 c
03313 if (iopen.eq.0) then
03314 if (iprompt.eq.1) then
03315 call devoff
03316 write(6,*)'No file open'
03317 go to 10
03318 else
03319 go to 1001
03320 end if
03321 end if
03322 c
03323 call readall(10,input,istart,nin,x,nx,nhead,nmax,
03324 $ iprompt,*1001)
03325 c
03326 end if
03327 c
03328 else if (c1.eq.'y') then
03329 c
03330 if (c2.eq.' ') then
03331 c
03332 c Y: Read the y array.
03333 c
03334 if (iopen.eq.0) then
03335 if (iprompt.eq.1) then
03336 call devoff
03337 write(6,*)'No file open'
03338 go to 10
03339 else
03340 go to 1001
03341 end if
03342 end if
03343 c
03344 call readiq(input(istart:nin),1,
03345 & iy,idum,idum,idum,*1001)
03346 if (iy.le.0)go to 1001
03347 c
03348 call readcols(10,nhead,nrange,iy,iy,x,y,z,ny,nmax,
03349 & c1,0,iprompt,*1001)
03350 c
03351 else if (c2.eq.'y') then
03352 c
03353 c YY: Read the y array, without worrying about columns.
03354 c
03355 if (iopen.eq.0) then
03356 if (iprompt.eq.1) then
03357 call devoff
03358 write(6,*)'No file open'
03359 go to 10
03360 else
03361 go to 1001
03362 end if
03363 end if
03364 c
03365 call readall(10,input,istart,nin,y,ny,nhead,nmax,
03366 $ iprompt,*1001)
03367 c
03368 else if (c2.eq.'h') then
03369 c
03370 c YH: Toggle y label size following x.
03371 c
03372 call getyfollowsx(iy)
03373 call setyfollowsx(1 - iy)
03374 c
03375 else if (c2.eq.'l') then
03376 c
03377 c YL: Specify y label.
03378 c
03379 yttl=' '
03380 if (istart.le.nin)yttl=input(istart:nin)
03381 if (c3.eq.'p'.and.ibox.eq.1) call labels(' ',yttl)
03382 c
03383 else if (c2.eq.'a') then
03384 c
03385 c YA: Set y-axis mode.
03386 c
03387 call readiq(input(istart:nin),1,
03388 & ly,idum,idum,idum,*1001)
03389 call setyaxis(ly)
03390 c
03391 else if (c2.eq.'o') then
03392 c
03393 c YO: Set y-axis (YON, YOFF).
03394 c
03395 if (c3.eq.'f') then
03396 call setyaxis(-1)
03397 else if (c3.eq.'n') then
03398 call setyaxis(0)
03399 end if
03400 c
03401 end if
03402 c
03403 else if (c1.eq.'z') then
03404 c
03405 if (c2.eq.'s') then
03406 c
03407 c ZS: Display the zoom stack.
03408 c
03409 if (ireplay.eq.0.and.iprompt.eq.1) then
03410 do 600 iz=1,nzoom
03411 write(6,*)iz,xlzoom(iz),xrzoom(iz),
03412 & ybzoom(iz),ytzoom(iz)
03413 600 continue
03414 end if
03415 c
03416 else if (c2.eq.'o'.or.c2.eq.'+'.or.c2.eq.'-'.or.c2.eq.'0')
03417 & then
03418 c
03419 c ZO(+,-,0): Zoom in/out on a particular plot region.
03420 c
03421 if (ibox.eq.0) go to 1001
03422 c
03423 c Work with izoom, rather than nzoom, throughout.
03424 c
03425 if (ireplay.eq.0) izoom = nzoom
03426 c
03427 izm = 0
03428 if (c2.eq.'-'.or.c2.eq.'0') izm = 1
03429 c
03430 if (izm.eq.0.and.izoom.ge.NZMAX) then
03431 if (iprompt.eq.1) then
03432 call devoff
03433 write(6,*)'Zoom stack full !'
03434 end if
03435 go to 1001
03436 else if (izm.eq.1.and.izoom.le.0) then
03437 go to 1001
03438 end if
03439 c
03440 if (izm.eq.0) then
03441 if (ireplay.eq.0) then
03442 c
03443 c Get graphic input.
03444 c
03445 if (iprompt.eq.1) then
03446 call devoff
03447 write(6,*)
03448 & 'Indicate bottom left, ',
03449 & 'top right corners'
03450 end if
03451 end if
03452 c
03453 call getgfx(r1,s1)
03454 call getgfx(r2,s2)
03455 c
03456 izoom = izoom + 1
03457 c
03458 if (ireplay.eq.0) then
03459 c
03460 c Save old limits on the zoom stack.
03461 c
03462 nzoom = nzoom + 1
03463 c
03464 xlzoom(nzoom) = xmin
03465 xrzoom(nzoom) = xmax
03466 ybzoom(nzoom) = ymin
03467 ytzoom(nzoom) = ymax
03468 end if
03469 c
03470 c Convert new limits to user units.
03471 c
03472 call fr users(r1,s1,xz1,yz1)
03473 call fr users(r2,s2,xz2,yz2)
03474 c
03475 xmin = min(xz1,xz2)
03476 ymin = min(yz1,yz2)
03477 xmax = max(xz1,xz2)
03478 ymax = max(yz1,yz2)
03479 c
03480 if (modex.lt.0) then
03481 xmin = 10.**xmin
03482 xmax = 10.**xmax
03483 end if
03484 c
03485 if (modey.lt.0) then
03486 ymin = 10.**ymin
03487 ymax = 10.**ymax
03488 end if
03489 c
03490 else
03491 c
03492 c Retrieve from the zoom stack.
03493 c
03494 if (c2.eq.'-'.and.istart.le.nin) then
03495 call readiq(input(istart:nin),1,
03496 & ndown,idum,idum,idum,*1001)
03497 c
03498 if (ndown.gt.izoom) then
03499 if (iprompt.eq.1)
03500 & write(6,*)'Zoom stack underflow'
03501 ndown = izoom
03502 end if
03503 else
03504 if (c2.eq.'-') then
03505 ndown = 1
03506 else
03507 ndown = izoom
03508 end if
03509 end if
03510 c
03511 izoom = izoom - ndown + 1
03512 c
03513 xmin = xlzoom(izoom)
03514 xmax = xrzoom(izoom)
03515 ymin = ybzoom(izoom)
03516 ymax = ytzoom(izoom)
03517 c
03518 izoom = izoom - 1
03519 if (ireplay.eq.0) nzoom = izoom
03520 end if
03521 c
03522 c Erase the appropriate segment of the screen.
03523 c
03524 if (jbox.eq.0) then
03525 call clear
03526 else
03527 call erase(-roff,.5*xsize-roff,
03528 & -soff,.5*ysize-soff)
03529 end if
03530 c
03531 c Draw the new box.
03532 c
03533 call eframe(xmin,xmax,xlen,modex,xttl,
03534 & ymin,ymax,ylen,modey,yttl)
03535 c
03536 if (iprompt.eq.1) then
03537 write(6,*)'Zoom level = ',izoom
03538 call devoff
03539 end if
03540 c
03541 else if (c2.eq.'z') then
03542 c
03543 c ZZ: Read the z array, without worrying about columns.
03544 c
03545 if (iopen.eq.0) then
03546 if (iprompt.eq.1) then
03547 call devoff
03548 write(6,*)'No file open'
03549 go to 10
03550 else
03551 go to 1001
03552 end if
03553 end if
03554 c
03555 call readall(10,input,istart,nin,z,nz,nhead,nmax,
03556 $ iprompt,*1001)
03557 c
03558 else
03559 c
03560 c Z: Read the z array.
03561 c
03562 if (iopen.eq.0) then
03563 if (iprompt.eq.1) then
03564 call devoff
03565 write(6,*)'No file open'
03566 go to 10
03567 else
03568 go to 1001
03569 end if
03570 end if
03571 c
03572 call readiq(input(istart:nin),1,
03573 & iz,idum,idum,idum,*1001)
03574 if (iz.le.0)go to 1001
03575 c
03576 call readcols(10,nhead,nrange,iz,iz,x,y,z,nz,nmax,
03577 & c1,0,iprompt,*1001)
03578 c
03579 end if
03580 end if
03581 c
03582 go to 10
03583 c
03584 c (Very) rudimentary error handling:
03585 c
03586 1001 if (inunit.eq.5.and.nino.eq.nl) then
03587 if (iprompt.eq.1) then
03588 if (audio.and.idev.eq.15) call message
03589 call devoff
03590 write(6,*)'Input error'
03591 end if
03592 else
03593 if (iprompt.eq.1) then
03594 if (audio.and.idev.eq.15) call message
03595 call devoff
03596 write(6,*)'Input error ('
03597 & input(1:max(1,nino-1))
03598 end if
03599 end if
03600 c
03601 c Terminate looping and force a new line to be read:
03602 c
03603 if (loop.ge.0) then
03604 loop = -1
03605 iscolon = nl + 1
03606 end if
03607 c
03608 go to 10
03609 c
03610 99999 end
03611
03612
03613 subroutine modifyh(hlast,h,c3,input,*)
03614 save
03615 character*1 c3
03616 character*(*) input
03617 c
03618 c Modify h according to the contents of c3 and inout.
03619 c
03620 c
03621 if (c3.eq.'-') then
03622 h = hlast
03623 else if (c3.eq.'*') then
03624 hlast = h
03625 call readrq(input,1,
03626 & fac,dum,dum,dum,*1001)
03627 if (fac.ge.0.) h = h * fac
03628 else if (c3.eq.'/') then
03629 hlast = h
03630 call readrq(input,1,
03631 & fac,dum,dum,dum,*1001)
03632 if (fac.gt.0.) h = h / fac
03633 else
03634 hlast = h
03635 call readrq(input,1,
03636 & h,dum,dum,dum,*1001)
03637 end if
03638 c
03639 return
03640 1001 return 1
03641 c
03642 end
03643
03644
03645 subroutine message
03646 save
03647 c
03648 c Output an audio message, if possible.
03649 c
03650 character*80 value,file
03651 c
03652 c call mygetenv('SHELL',value)
03653 c if (index(value,'/bin/csh').eq.0) return
03654 c
03655 call mygetenv('WINDOW_PARENT',value)
03656 if (index(value,'/dev/win').eq.0) return
03657 c
03658 file = '/home/zonker_export/steve/sorrydave.au'
03659 idum = mysystem(
03660 & '(((cat '
03661 c
03662 write(6,*)
03663 & '(To turn off the annoying audio message, type "h-")'
03664 c
03665 end
03666
03667
03668 subroutine readrq(string,n,a1,a2,a3,a4, *)
03669 c
03670 c Read a specified number of real arguments from a string.
03671 c
03672 character*(*) string
03673 real a1,a2,a3,a4
03674 character*50 temp(20)
03675 common /read_token_stat/ io
03676 c
03677 call gettokens(string,temp,nt)
03678 c
03679 if (nt.eq.1) then
03680 call readrtoken(temp(1),a1,a1)
03681 else if (nt.eq.2) then
03682 call readrtoken(temp(1),a1,a1)
03683 if (io.ne.0) return 1
03684 call readrtoken(temp(2),a2,a2)
03685 else if (nt.eq.3) then
03686 call readrtoken(temp(1),a1,a1)
03687 if (io.ne.0) return 1
03688 call readrtoken(temp(2),a2,a2)
03689 if (io.ne.0) return 1
03690 call readrtoken(temp(3),a3,a3)
03691 else if (nt.eq.4) then
03692 call readrtoken(temp(1),a1,a1)
03693 if (io.ne.0) return 1
03694 call readrtoken(temp(2),a2,a2)
03695 if (io.ne.0) return 1
03696 call readrtoken(temp(3),a3,a3)
03697 if (io.ne.0) return 1
03698 call readrtoken(temp(4),a4,a4)
03699 end if
03700 if (io.ne.0) return 1
03701 c
03702 end
03703
03704
03705 subroutine readiq(string,n,a1,a2,a3,a4,*)
03706 c
03707 c Read a specified number of integer arguments from a string.
03708 c
03709 character*(*) string
03710 integer a1,a2,a3,a4
03711 character*50 temp(20)
03712 common /read_token_stat/ io
03713 c
03714 call gettokens(string,temp,nt)
03715 c
03716 if (nt.eq.1) then
03717 call readitoken(temp(1),a1,a1)
03718 else if (nt.eq.2) then
03719 call readitoken(temp(1),a1,a1)
03720 if (io.ne.0) return 1
03721 call readitoken(temp(2),a2,a2)
03722 else if (nt.eq.3) then
03723 call readitoken(temp(1),a1,a1)
03724 if (io.ne.0) return 1
03725 call readitoken(temp(2),a2,a2)
03726 if (io.ne.0) return 1
03727 call readitoken(temp(3),a3,a3)
03728 else if (nt.eq.4) then
03729 call readitoken(temp(1),a1,a1)
03730 if (io.ne.0) return 1
03731 call readitoken(temp(2),a2,a2)
03732 if (io.ne.0) return 1
03733 call readitoken(temp(3),a3,a3)
03734 if (io.ne.0) return 1
03735 call readitoken(temp(4),a4,a4)
03736 end if
03737 if (io.ne.0) return 1
03738 c
03739 end
03740
03741
03742 subroutine plain_sim(string, nstring)
03743 c
03744 c Replace numbers in string by "plain-font" versions.
03745 c
03746 character*(*) string
03747 integer nstring
03748 c
03749 if (nstring.le.0) return
03750 c
03751 ndigit = 0
03752 do i=1,nstring
03753 if (string(i:i).ge.'0'.and.string(i:i).le.'9'
03754 $ .and.(i.eq.1.or.(string(i-1:i-1).ne.'@'
03755 $ .and.string(i-1:i-1).ne.'%')))
03756 $ ndigit = ndigit + 1
03757 end do
03758 c
03759 c String is pure numeric. Replace digit by "@digit".
03760 c
03761 nstring = nstring+ndigit
03762 i = nstring
03763 do while (i.gt.0)
03764 string(i:i) = string(i-ndigit:i-ndigit)
03765 ind = i-ndigit-1
03766 if (string(i:i).ge.'0'.and.string(i:i).le.'9'
03767 $ .and.(i.eq.1.or.(string(ind:ind).ne.'@'
03768 $ .and.string(ind:ind).ne.'%'))) then
03769 i = i - 1
03770 string(i:i) = '@'
03771 ndigit = ndigit - 1
03772 end if
03773 i = i - 1
03774 end do
03775 c
03776 if (ndigit.ne.0) write(6,*)'Error in plain_sim!!!!!!!'
03777 c
03778 end
