C234567 program pgmao C plotprogram using pgplot library C by TJ Pearson C C the data are read from default tape : tape5 C all (!) data are read and all plotted, at least thought so C C ************************************************************************* C C IMPORTANT: C to use pgplot, the following line needs to be in C your .cshrc - file , C1A .and. C1B respectively C C setenv PGPLOT_FONT /a/aux0/cit.vlbi/pgplot/fonts/grfont.dat C C ************************************************************************* C C the use of FIThis (see below) has successfully been tested now C else use of FITfff (see below) has not been tested up to now C C N.B.: current maximum of plots : 20 C current maximum of sub-plots : 2 C current maximum of points per sub-plot : 2000 C C ************************************************************************* C C the tape5 STANDART HEADER: C C *lable_top C *lable_x-axis C *lable_y-axis C *SYMBOLiiiJUSjjjNEW xmin xmax ymin ymax C *PLOTYPpppFITfff C { if fff.ne.000 } { *lolim uplim A0 A1 A2 } C x(i) dx(i) y(i) dy(i) C . . . . C . . . . C . . . . C C iii - of format I3.3 C 000 - 031 standart marker symbols (e-mail me for a copy) C 032 - 127 represent ASCII characters, symbol=ichar('f') C 128 -4000 Hershey symbol number C C jjj - of format I3.3 , pg-plot allows : C 000 - x- and y-axis scaled independently C 001 - x- and y-axis scaled equaly C C NEW - data following this header into new plot C if _blank_ 'sub-plot' into previous plot C C {if NEW} xmin ... of free format REAL , margins of plot C C ppp - of format I3.3 C 001 - draw coordinates C 002 - draw coordinates with grid overlay C 010 - x-axis logarithmically C 020 - y-axis logarithmically C 030 - x-axis and y-axis logarithmically C 1__ - draw polygon on points , add 01 02 10 20 or 30 C N.B.: if you want logtharithmic scales, C nevertheless use 'normal' data C the values are scaled automatically C C pgplot provides a simple method to plot a function into a graph C or a histogram C {if} fff.ne.000 .or. fff. C C fff - of format A3 , pg-mao allows yet : C C 000 - no fit C C his - make histogram C lolim uplim - range of x C A0 - number of bin-intervals C A1 - 0 for new frame C 1 for using old frame C A2 - _blank_ C C spc - y = A0 + A1 * log10(x) + A2 * log10(x)**2 C C lolim uplim - range of x C A0 A1 A2 of free format REAL C C if you need another function e-mail me C and you will get your personal number C C {endif} C C -------------- INFO END ------------ C plotlim : max number plots C splotlim : max number sub-plots in one plot C ptslim : max number of points in one sub-plot C curvat : N integer plotlim,splotlim,ptslim parameter (plotlim=40) parameter (splotlim=2) parameter (ptslim=200) real xpts(ptslim,splotlim,plotlim),ypts(ptslim,splotlim,plotlim) real dxpts(ptslim,splotlim,plotlim),dypts(ptslim,splotlim,plotlim) real XLO(ptslim),XHI(ptslim),YLO(ptslim),YHI(ptslim) real xmin(plotlim), xmax(plotlim), ymin(plotlim), ymax(plotlim) real lolim(splotlim,plotlim),uplim(splotlim,plotlim) common /fitcoef/ A0(splotlim,plotlim), A1(splotlim,plotlim), & A2(splotlim,plotlim) character*3 new , funcnam(splotlim,plotlim) character*10 device character*5 intape character*40 labeltop(plotlim),labelx(plotlim),labely(plotlim) character*80 fname integer just(plotlim),axis(plotlim) integer pltnum,spltnum(plotlim),ptsnum(splotlim,plotlim) integer symbol(splotlim,plotlim) integer numx, numy logical line(splotlim,plotlim),hist(splotlim,plotlim) logical func(splotlim,plotlim) common /isip/ iplt,ispl intape='tape5' C *** M A I N c call PGQCH(BLA) c write(6,*)'Charactersize is =' c write(6,*)bla c write(6,*)'Enter new size! (2 is recommended!)' c read(5,*)bla bla=2 call PGSCH(bla) call welcome call readtape( 1labeltop,labelx,labely, 2xmin,xmax,ymin,ymax,lolim,uplim,funcnam, 3just,axis, 4pointnum,xpts,ypts,dxpts,dypts,symbol, 5pltnum,spltnum,ptsnum, 6line,hist,func) call askdevice(device,numx,numy) ipagesize=numx*numy 1234 call PGBEGIN(0,device,numx,numy) c call PGBEGIN(0,'?',numx,numy) call pgsch(bla) call PGSCF(1) c write(6,*)' Enter frame color and plot color!' c read(5,*)ifcol,ipcol ifcol=5 ipcol=12 C *** LOOP for plot frames do 4100 ip=1,pltnum do 4203 is=1,spltnum(ip) if ((hist(is,ip)).and.(A1(is,ip).eq.0.)) goto 4202 4203 continue call pgsci(ifcol) call PGENV(xmin(ip),xmax(ip),ymin(ip),ymax(ip), &just(ip),axis(ip)) call PGLABEL(labelx(ip),labely(ip),labeltop(ip)) call pgsci(ipcol) C --- LOOP for sub plots 4202 continue do 4200 is=1,spltnum(ip) if (hist(is,ip)) then ibin=A0(is,ip) ipgflag=A1(is,ip) call PGHIST(ptsnum(is,ip),xpts(1,is,ip), + lolim(is,ip),uplim(is,ip),ibin,ipgflag) call PGLABEL(labelx(ip),labely(ip),labeltop(ip)) hist(is,ip) = .false. goto 4200 endif call PGPOINT(ptsnum(is,ip),xpts(1,is,ip),ypts(1,is,ip), & symbol(is,ip)) C error bars do 4310 i=1,ptsnum(is,ip) XHI(i)=xpts(i,is,ip)+dxpts(i,is,ip) XLO(i)=xpts(i,is,ip)-dxpts(i,is,ip) 4310 continue call PGERRX(ptsnum(is,ip),XLO,XHI,ypts(1,is,ip),1.0) do 4320 i=1,ptsnum(is,ip) YHI(i)=ypts(i,is,ip)+dypts(i,is,ip) YLO(i)=ypts(i,is,ip)-dypts(i,is,ip) 4320 continue call PGERRY(ptsnum(is,ip),xpts(1,is,ip),YHI,YLO,1.0) if(line(is,ip)) &call PGLINE(ptsnum(is,ip),xpts(1,is,ip),ypts(1,is,ip)) iplt=ip ispl=is if (func(is,ip)) +call funcs(nplt,nspl,funcnam(is,ip),lolim(is,ip),uplim(is,ip)) 4200 continue C --- -------- 4100 continue C *** -------- call PGIDEN call PGEND c goto 1234 end C *** S U B R O U T I N E S ********************************* subroutine funcs(name,lolim,uplim) integer lolim,uplim character*3 name if (name.eq.'spc') + call PGFUNX(spc,100,lolim,uplim,1) return end real function spc(x) parameter(nplt=40) parameter(nspl=2) parameter(npts=200) common /fitcoef/ A0(nspl,nplt),A1(nspl,nplt),A2(nspl,nplt) common /isip/ ip,is spc=A0(is,ip) + A1(is,ip) * log10(x) + A2(is,ip) * log10(x)**2 end C ------------- END of FUNCTION block ----------------- subroutine askdevice(device,numx,numy) character*10 device device='/gf' C number of plots in x / y - directions numx=1 numy=1 write(6,*)'*** choose output device ' write(6,*)' s screen (/EGA)' write(6,*)' p LASPLOT / portrait ' write(6,*)' l LASPLOT / landscape ' write(6,*) read(5,*)device write(6,*)'*** choose number of plots per page ' write(6,*)' enter number in x and y direction' write(6,*) read(5,*)numx,numy c if ((device.eq.'p').or.(device.eq.'l')) then c write(6,*)' output : LAS plot file in cwd ' c write(6,*)' names : PGPLOT.QMPLOT or PGPLOT.VQMPLOT ' c write(6,*)' rename with _mv_ to LAS**' c write(6,*) c endif if (device.eq.'s') device='/EGA' if (device.eq.'p') device='/LPL' if (device.eq.'l') device='/LPM' end C ----------------------------- subroutine readtape( 1labeltop,labelx,labely, 2xmin,xmax,ymin,ymax,lolim,uplim,funcnam, 3just,axis, 4pointnum,xpts,ypts,dxpts,dypts,symbol, 5pltnum,spltnum,ptsnum, 6line,hist,func) integer nplt,nspl,npts parameter(nplt=40) parameter(nspl=2) parameter(npts=200) character*40 labelx(nplt),labely(nplt),labeltop(nplt) character*40 dumt,dumx,dumy,infile character*80 dum80 character*1 dum1 integer just(nplt),axis(nplt) integer pltnum,spltnum(nplt),ptsnum(nspl,nplt) integer symbol(nspl,nplt),dumsym real xpts(npts,nspl,nplt), ypts(npts,nspl,nplt) real dxpts(npts,nspl,nplt), dypts(npts,nspl,nplt) real xmin(nplt), xmax(nplt), ymin(nplt), ymax(nplt) real lolim(nspl,nplt),uplim(nspl,nplt) common /fitcoef/ A0(nspl,nplt),A1(nspl,nplt),A2(nspl,nplt) character*3 new , fit , funcnam(nspl,nplt) character*10 device character*5 intape logical line(nspl,nplt),hist(nspl,nplt) logical func(nspl,nplt) logical fnew write(6,*)'Enter filename!' read(5,1)infile 1 format(a40) c infile='tape5' open(15,file=infile) 1020 format(a) 1030 format(7x,i3.3) 1040 format(a3) C loop ---- READ header ip=0 is=0 i=0 2000 continue C three lables read(15,1020,err=3010,end=1990)dumt 3010 read(15,1020,err=3020)dumx 3020 read(15,1020,err=3030)dumy C header line : symbol ... 3030 read(15,1020)dum80 read(dum80,1030)dumsym read(dum80(17:19),1040,err=3040)new if (new.eq.'NEW') then ip=ip+1 is=0 read(dum80(20:),*,err=3040)xmin(ip),xmax(ip),ymin(ip),ymax(ip) endif 3040 continue is=is+1 spltnum(ip)=is pltnum=ip if (new.eq.'NEW') then labeltop(ip)=dumt(2:) labelx(ip)=dumx(2:) labely(ip)=dumy(2:) endif symbol(is,ip)=dumsym if (is.eq.1) read(dum80(14:),'(i3.3)')just(ip) C header line : plotyp .... read(15,1020)dum80 read(dum80,1050)dum1,axis(ip) 1050 format(7x,a1,i2.2) if (dum1.eq.'1') line(is,ip)=.true. read(dum80(11:),1060,err=3050)fit,funcnam(is,ip) 1060 format(a3,a3) if ((fit.ne.'FIT').or.(funcnam(is,ip).eq.'000')) goto 3050 if (funcnam(is,ip).eq.'his') then hist(is,ip)=.true. write(6,*)'*** hist is true ' else func(is,ip)=.true. endif read(15,1020,err=3050)dum80 read(dum80(2:),*,err=3050)lolim(is,ip),uplim(is,ip), + A0(is,ip),A1(is,ip),A2(is,ip) 3050 continue C --- logarithm of frame ---------- if (is.eq.1) then if ((axis(ip).eq.30).or.(axis(ip).eq.10)) then if (xmin(ip).ne.0) xmin(ip)=log10(xmin(ip)) if (xmax(ip).ne.0) xmax(ip)=log10(xmax(ip)) if (lolim(is,ip).ne.0) lolim(is,ip)=log10(lolim(is,ip)) if (uplim(is,ip).ne.0) uplim(is,ip)=log10(uplim(is,ip)) endif if ((axis(ip).eq.30).or.(axis(ip).eq.20)) then if (ymin(ip).ne.0) ymin(ip)=log10(ymin(ip)) if (ymax(ip).ne.0) ymax(ip)=log10(ymax(ip)) endif endif C --- end of logarithm of frame ---------- C read data i=0 C data loop read(15,1020,end=1990)dum80 if (dum80(1:1).eq.'*') then backspace(15) goto 2000 endif flag=0 if(xmax(ip).eq.0.and.ymax(ip).eq.0.and. & xmin(ip).eq.0.and.ymin(ip).eq.0)then xmax(ip)=-1E36 xmin(ip)=-xmax(ip) ymin(ip)=1E36 ymax(ip)=-ymin(ip) flag=1 endif 200 i=i+1 read(dum80,*) &xpts(i,is,ip),dxpts(i,is,ip),ypts(i,is,ip),dypts(i,is,ip) if(flag.eq.1)then xmax(ip)=max(xmax(ip),xpts(i,is,ip)) xmin(ip)=min(xmin(ip),xpts(i,is,ip)) ymax(ip)=max(ymax(ip),ypts(i,is,ip)) ymin(ip)=min(ymin(ip),ypts(i,is,ip)) endif read(15,1020,end=1995)dum80 if (dum80(1:1).ne.'*') goto 200 backspace(15) 1995 continue if(flag.eq.1)then xmax(ip)=xmax(ip)+(xmax(ip)-xmin(ip))/10. xmin(ip)=xmin(ip)-(xmax(ip)-xmin(ip))/10. ymax(ip)=ymax(ip)+(ymax(ip)-ymin(ip))/10. ymin(ip)=ymin(ip)-(ymax(ip)-ymin(ip))/10. endif ptsnum(is,ip)=i C ---- logarithmizing if ((axis(ip).eq.30).or.(axis(ip).eq.10)) then do 2230 i=1,ptsnum(is,ip) x = xpts(i,is,ip) dx=dxpts(i,is,ip) if (x.ne.0) xpts(i,is,ip)=log10(x) if (dx.ne.0) dxpts(i,is,ip)=log10(x+dx)-log10(x) 2230 continue endif if ((axis(ip).eq.30).or.(axis(ip).eq.20)) then do 2240 i=1,ptsnum(is,ip) y = ypts(i,is,ip) dy=dypts(i,is,ip) if (y.ne.0) ypts(i,is,ip)=log10(y) if (dy.ne.0) dypts(i,is,ip)=log10(y+dy)-log10(y) 2240 continue endif C ---- end of logarithmizing goto 2000 C ----- end of read loop C ----- prepare exit of subroutine 1990 continue close(15) write(6,1997)pltnum 1997 format(' ========>> ',i4.4,' plots were read from tape5') write(6,*) return end C ----------------------------- subroutine welcome character*1 z write(6,*) write(6,*)'***************************************************' write(6,*)'*** Welcome to PG - MAO, a plot program using ***' write(6,*)'*** PGPLOT ***' write(6,*)'*** *lable_top ***' write(6,*)'*** *lable_x-axis ***' write(6,*)'*** *lable_y-axis ***' write(6,*)'*** *SYMBOLiiiJUSjjjNEW xmin xmax ymin ymax ***' write(6,*)'*** *PLOTYPpppFITfff ***' write(6,*)'*** x dx y dx ***' write(6,*)'*** . . . . ***' write(6,*)'*** Symbols: 0,6,19 Quadrangles, 1 Point, ***' write(6,*)'*** 4,20 - 27 Circles, 2 Plus, 3 Asterisk, ***' write(6,*)'*** 5 Cross, 7 Triangle, 13 Filled Triangle ***' write(6,*)'*** 8 Bigoplus, 9 Odot, 10 Pillow, 11 Diamond,***' write(6,*)'*** 12 Star, 14 RedCross, 16 Filled Square, ***' write(6,*)'*** 17 Filled Circle, 18 Filled Star ***' write(6,*)'*** JUS000 x- and y-axis scaled independently ***' write(6,*)'*** 001 equaly ***' write(6,*)'*** ppp 001 - draw coordinates ***' write(6,*)'*** 002 - draw coordinates with grid ***' write(6,*)'*** 010 - x-axis logarithmically ***' write(6,*)'*** 020 - y-axis logarithmically ***' write(6,*)'*** 030 - x-axis and y-axis log. ***' write(6,*)'***************************************************' c write(6,*)'*** you find infos in ***' c write(6,*) c write(6,*)'*** or /b/mnt/p581mao/pgplot/pginfo01 ***' c write(6,*)'*** or /b/mnt/p581mao/pgplot/pgmao01.f ***' c write(6,*) c write(6,*)'*** please e-mail bugs and suggestions ***' c write(6,*) c write(6,*)'press to read data from tape5 ")') c read(5,'(a)')z return end