c subroutine pltkey (key,xdat,ydat,zdat,instr,ndatpt) c c PROGRAM NAME: PLTKEY.rat c c DATE OF FIRST VERSION: 1-Apr-80 c DATE OF CURRENT VERSION: 21-Jun-83 c c PURPOSE: PLT routine to control activities associated c with keywords. c c USAGE: call PLTKEY (KEY,XDAT,YDAT,ZDAT,INSTR,NDATPT) c c where KEY = Integer value associated with the keyword c XDAT,YDAT,ZDAT = Real*4 data arrays c INSTR = Command line entered from LUNIN c NDATPT = Number of data values in buffer c c SUBROUTINES REQUIRED: PLOT2, DATTIM, AXES4, HISTO, LINPLT c PUTMSG, NEWPEN, SYMBOL, NAMFIL c c PROGRAMMER: Mike Collins / Eric Javel / Matt Prucka c c************************************************************** dimension xdat(1),ydat(1),zdat(1) byte instr(1),flspec(28),junk logical*1 pltyet c c Common block for PLT parameters c real*8prmnam,txtnam,keywrd bytexlabel,ylabel,rlabel,xfmt,yfmt,rfmt,msg,filonm(14) bytefilinm(40) logical*1dataon,pltfnd,msgflg,finflg,modflg,conton,axflg,newpag, & ecflg,typerr,dbflg c common /params/xmin,xmax,xint,xcycle,xpct,xlen,xllc,ymin,ymax, & yint,ycycle,ypct,ylen,yllc,rmin,rmax,rint,rcycle,rpct,pltype, & typlin,pltlin,symnum,sizsym,solid,sizann,wtlnan,xanlab,yanlab, & ranlab,yhor,grid,sizlab,wtlnlb,ticmrk,shade,echo,wtlnax,openax, & sizmsg,wtlnms,xmsg,ymsg,angmsg,datmsg,sizfac,smooth,header,sort, & unused(1) common /flags/dataon,pltfnd,msgflg,finflg,modflg,conton,axflg, & newpag,ecflg,typerr,dbflg common /names/prmnam(50),txtnam(6),keywrd(25),filinm,filonm common /text/xlabel(52),ylabel(52),rlabel(52),xfmt(6),yfmt(6), & rfmt(6),msg(256) common /misc/ifrom,ito,inow,ipage,model,lunin,lunout c common /axes/rxmin,rxmax,rymin,rymax,rxlen,rylen,rxllc,ryllc, & pxmin,pxmax,pymin,pymax,pxlen,pylen,pxllc,pyllc common /size/tiklen,hitann,hitlab,hitsym,hitmsg,iaxlnw,igrlnw, & ianlnw,ilblnw,ipllnw,imslnw,avgaxl common /msks/ msk1,msk2,msk3,msk4,msk5 external len,index data pltyet /.false./ 1 format (' Illegal CALL/INCLUDE nesting') 2 format (' Current Data Values (X,Y,Z) :') 3 format (3f10.3) 4 format (' Data Buffer Empty') 6 format (' Illegal RUN nesting') 85 format(1a1) c c----------------------------------------------------------------- c if(.not.(key .eq. 1))goto 23000 c PLOT entered pltyet = .true. call setsiz c See if we allowed to plot yet. if(.not.(inow .lt. ifrom))goto 23002 return c We are. See if this is a new page. 23002 continue if(.not.(dbflg))goto 23004 type *,' pltkey: inow,header,ipage=',inow,header,ipage 23004 continue if(.not.(newpag))goto 23006 if(.not.(inow.gt.1))goto 23008 call page 23008 continue newpag = .false. c Draw the header stuff, maybe if(.not.(header .ne. 0.))goto 23010 call dattim 23010 continue ipage = ipage+1 c Draw the axes, if that hasn't been done yet. 23006 continue if(.not.(axflg))goto 23012 if(.not.(dbflg))goto 23014 type *,' pltkey -> axes4' 23014 continue call axes4 axflg = .false. c Draw the data, if data exist 23012 continue if(.not.(ndatpt .gt. 0))goto 23016 if(.not.(dbflg))goto 23018 type *,' pltkey -> linplt' 23018 continue if(.not.(pltype .eq. 4))goto 23020 call histo (ndatpt,xdat) goto 23021 c else 23020 continue call linplt (ndatpt,xdat,ydat,zdat) 23021 continue ndatpt = 0 c Install the message, if one exists 23016 continue if(.not.(msgflg))goto 23022 if(.not.(dbflg))goto 23024 type *,' pltkey -> putmsg' 23024 continue call putmsg msgflg = .false. 23022 continue goto 23001 c else 23000 continue if(.not.(key .eq. 4))goto 23026 c DATA entered ndatpt = 0 goto 23027 c else 23026 continue if(.not.(key .eq. 7))goto 23028 c FINISH entered call setsiz if(.not.(axflg))goto 23030 c Clean up any unresolved stuff call axes4 axflg = .false. 23030 continue if(.not.(ndatpt .gt. 0))goto 23032 if(.not.(pltype .eq. 4))goto 23034 call histo (ndatpt,xdat) goto 23035 c else 23034 continue call linplt (ndatpt,xdat,ydat,zdat) 23035 continue ndatpt = 0 23032 continue if(.not.(msgflg))goto 23036 call putmsg msgflg = .false. 23036 continue c Restore LUNIN or terminate call cnglun goto 23029 c else 23028 continue if(.not.(key .eq. 11))goto 23038 c NEWFRAME entered if(.not.(dbflg))goto 23040 type *,' pltkey -> newframe' 23040 continue axflg = .true. pltyet = .false. msgflg = .false. goto 23039 c else 23038 continue if(.not.(key .eq. 10))goto 23042 c NEWPAGE entered if(.not.(dbflg))goto 23044 type *,' pltkey -> newpage' 23044 continue newpag = .true. axflg = .true. msgflg = .false. inow = inow+1 pltyet = .false. goto 23043 c else 23042 continue if(.not.(key .eq. 13 .or. key .eq. 14))goto 23046 c CALL or INCLUDE if(.not.(lunin .ne. 3))goto 23048 c CALL is legal only from main file write (5,1) return 23048 continue if(.not.(index(instr,'*') .ne. 0))goto 23050 c If file name input requested call namfil (flspec,'.PLT') goto 23051 c else 23050 continue call scopy (instr(index(instr,' ')+1),flspec) if(.not.(index(flspec,'.') .eq. 0))goto 23052 call scopy('.PLT',flspec(len(flspec)+1)) 23052 continue 23051 continue open (unit=4,name=flspec,type='OLD',err=100, & readonly) lunin = 4 goto 23047 c else 23046 continue if(.not.(key .eq. 2))goto 23054 c DATALIST if(.not.(ndatpt .gt. 0))goto 23056 write (5,2) c for i=1 23058 if(.not.(i.le.ndatpt))goto 23060 write (5,3) xdat(i),ydat(i),zdat(i) i=i+1 goto 23058 c endfor 23060 continue goto 23057 c else 23056 continue write (5,4) 23057 continue goto 23055 c else 23054 continue if(.not.(key.eq.12))goto 23061 c PRMLIST call wrprml(5) if(.not.(dbflg))goto 23063 call wrprml(6) 23063 continue pause 'PRMLST' goto 23062 c else 23061 continue if(.not.(key .eq. 15))goto 23065 c RUN if(.not.(lunin .ne. 3))goto 23067 write (5,6) return 23067 continue if(.not.(index(instr,'*') .ne. 0)) & goto 23069 c If file name input requested call namfil (flspec,'.TSK') goto 23070 c else 23069 continue call scopy (instr(index(instr,' ')+1) & ,flspec) 23070 continue 23065 continue 23062 continue 23055 continue 23047 continue 23043 continue 23039 continue 23029 continue 23027 continue 23001 continue return 100 type *,' *** error - could not open INCLUDE or CALL file' return end c wrprml - write parameter list to lun subroutine wrprml(lun) integer lun c c Common block for PLT parameters c real*8prmnam,txtnam,keywrd bytexlabel,ylabel,rlabel,xfmt,yfmt,rfmt,msg,filonm(14) bytefilinm(40) logical*1dataon,pltfnd,msgflg,finflg,modflg,conton,axflg,newpag, & ecflg,typerr,dbflg c common /params/xmin,xmax,xint,xcycle,xpct,xlen,xllc,ymin,ymax, & yint,ycycle,ypct,ylen,yllc,rmin,rmax,rint,rcycle,rpct,pltype, & typlin,pltlin,symnum,sizsym,solid,sizann,wtlnan,xanlab,yanlab, & ranlab,yhor,grid,sizlab,wtlnlb,ticmrk,shade,echo,wtlnax,openax, & sizmsg,wtlnms,xmsg,ymsg,angmsg,datmsg,sizfac,smooth,header,sort, & unused(1) common /flags/dataon,pltfnd,msgflg,finflg,modflg,conton,axflg, & newpag,ecflg,typerr,dbflg common /names/prmnam(50),txtnam(6),keywrd(25),filinm,filonm common /text/xlabel(52),ylabel(52),rlabel(52),xfmt(6),yfmt(6), & rfmt(6),msg(256) common /misc/ifrom,ito,inow,ipage,model,lunin,lunout c common /axes/rxmin,rxmax,rymin,rymax,rxlen,rylen,rxllc,ryllc, & pxmin,pxmax,pymin,pymax,pxlen,pylen,pxllc,pyllc common /size/tiklen,hitann,hitlab,hitsym,hitmsg,iaxlnw,igrlnw, & ianlnw,ilblnw,ipllnw,imslnw,avgaxl common /msks/ msk1,msk2,msk3,msk4,msk5 write (lun,1) xmin,xmax,xint,xcycle,xpct,xlen,xllc,xanlab,ymin, & ymax,yint,ycycle,ypct,ylen,yllc,yanlab,rmin,rmax,rint,rcycle, & rpct,ranlab,pltype,typlin,symnum,solid,grid,shade,ticmrk,openax, & yhor,sizsym,sizann,sizlab,sizmsg,sizfac,echo,header,smooth,sort, & xmsg,ymsg,angmsg,datmsg,wtlnan,wtlnlb,wtlnms,wtlnax,pltlin return 1 format (/,' Current Parameter Values:'//, & ' axis MIN MAX INT CYCLE PER LEN LLC & ANSKP'/,' X ',8f8.2/,' Y ',8f8.2/,' R ', & 5f8.2,16x,f8.2//, & ' PLTYPE LINTYP SYMBOL SOLID GRID SHADE TICDIR OPENA & X YHOR'/,' ',9f8.2//, & ' SYMSIZ ANNSIZ LABSIZ MSGSIZ SIZFAC ECHO HEADER SMOOT & H SORT'/,' ',9f8.2//, & ' MXLLC MYLLC MSGANG MSGDAT ANNLWT LABLWT MSGLWT AXLW & T PLTLWT'/,' ',9f8.2//) end