cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc 27 May 12 v 1.1a WJS cc cc Must external SCALE since it is "now" a FORTRAN cc cc intrinsic function cc cc 25 Jan 12 v 1.1a WJS cc cc 0 no longer accepted as floating point by most cc cc recent compiler cc cc Version 1.1 cc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc program axis include '../lib/penplot.com' real dis,dtic,apos,apos2,xa0,xa1,ya0,ya1,temp real labsiz real dl,du character*40 form,labl character*10 typ character*40 s character*20 names(10),vals(10) data names/ $ 'xamin','xamax','ypos','xatype','xasize', $ 'yamin','yamax','xpos','yatype','yasize'/ integer r1,r2 common/axiscom/xa0,ya0,xa1,ya1 external scale cccccccc call scale call readvara('plot.var',names,vals,10) c call tmode c write(*,*)xasize,yasize c call gmode xa0=default(vals(1),x0) xa1=default(vals(2),x1) apos=default(vals(3),y0) typ=vals(4) labsiz=default(vals(5),2.0) ya0=default(vals(6),y0) ya1=default(vals(7),y1) apos2=ya1 r1=0 r2=180 call getarg(1,s) if (s(1:1).eq.'y') then apos=default(vals(8),x0) apos2=xa1 typ=vals(9) labsiz=default(vals(10),2.0) r1=90 r2=270 endif if (xa0.gt.xa1) then temp=xa0 xa0=xa1 xa1=temp endif if (ya0.gt.ya1) then temp=ya0 ya0=ya1 ya1=temp endif call getarg(2,s) if(s.gt.' ') then read(s,*)dtic else if(r1.eq.0)then dtic=(xa1-xa0)/10.0 else dtic=(ya1-ya0)/10.0 endif endif call getarg(3,labl) if(labl.eq.'_')labl=' ' call getarg(4,s) if(s.gt.' ') then c write(*,*)s read(s,*)dis else if(r1.eq.0)then dis=(xa1-xa0)/5.0 else dis=(ya1-ya0)/5.0 endif endif if (iargc().gt.4) then call getarg(5,form) else form='xx.xx' endif c call tmode c write(*,*)apos,dtic,dis,labl,typ,labsiz c call gmode du=0 dl=0 if (index(typ,'rt').eq.0) then call axtic(apos,dtic,r1,dl) if (index(typ,'d').gt.0) call axtic(apos2,dtic,r2,du) else call axtic(apos,dtic,r2,du) if (index(typ,'d').gt.0) then call axtic(apos2,dtic,r1,du) du=0 endif endif if (dis.gt.0) then if (index(typ,'rn').eq.0) then call axnum(apos,dis,r1,form,dl,labsiz) else if (index(typ,'d').gt.0) then call axnum(apos2,dis,r2,form,du,labsiz) else call axnum(apos,dis,r2,form,du,labsiz) endif endif endif if (labl.gt.' ') then if (index(typ,'rl').eq.0) then call axtag(apos,r1,labl,dl,labsiz) else if (index(typ,'d').gt.0) then call axtag(apos2,r2,labl,du,labsiz) else call axtag(apos,r2,labl,du,labsiz) endif endif endif call endplt end c character*40 function default(t) c character*40 t cvar cit:integer cbegin c it=pos('&',t) c if t='&' then default='' c else if it=0 then default=t c else if it=1 then c default=copy(t,2,length(t)-1) c else c default=copy(t,1,it-1) cend real function default(t,rdef) character*20 t do 10 i=1,20 if(t(i:i).ne.' ')goto 11 10 continue default=rdef return 11 continue t=t(i:20) if(t.eq. 'default') then default=rdef else read(t,*)default endif return end character*40 function conv(y,form) character*40 form,temp,temp1 integer i,j i=index(form,'.') j=in_lnblnk(form) if (i.gt.0) i=j-i write(temp,*)'(F',j+3,'.',i,')' write(temp1,temp)y if(i.eq.0)then j=index(temp1,'.') temp1(j:40)=' ' endif do 10 i=1,40 if(temp1(i:i).ne.' ')goto 20 10 continue 20 continue conv=temp1(i:40) return end subroutine tic(x,y,dx,dy) include '../lib/penplot.com' xn=ax*x+bx yn=ay*y+by if(xn.ge.xv0-0.001 .and. xn.le.xv1+0.001 .and. $ yn.ge.yv0-0.001 .and. yn.le.yv1+0.001) then call plota(xn,yn) call plota(xn+dx,yn+dy) call penup endif return end subroutine axtic(org,dt,rot,del) integer rot common/axiscom/xa0,ya0,xa1,ya1 real xb,yb,xe,ye,tb,te,dx,dy if (rot.eq.0 .or. rot.eq.180) then tb=xa0 te=xa1 xb=xa0 yb=org xe=xa1 ye=org dx=dt dy=0 else tb=ya0 te=ya1 xb=org yb=ya0 xe=org ye=ya1 dx=0 dy=dt endif goto(10,11,12,13)rot/90+1 10 del=-2 goto 14 11 del=-1.5 goto 14 12 del=2 goto 14 13 del=1.5 14 continue call penup call plot(xb,yb) call plot(xe,ye) call penup if(dt.le.0.0)return 100 continue goto (20,21,22,23),rot/90+1 20 call tic(xb,yb,0.0,-2.0) goto 24 21 call tic(xb,yb,-1.5,0.0) goto 24 22 call tic(xb,yb,0.0,2.0) goto 24 23 call tic(xb,yb,1.5,0.0) 24 continue tb=tb+dt xb=xb+dx yb=yb+dy if(tb .lt.(te+dt/2))goto 100 return end subroutine axnum(org,dt,rotv,form,del,labsiz) common/axiscom/xa0,ya0,xa1,ya1 real org,dt,del,labsiz integer rotv character*40 form,conv real xb,yb,tb,te,dx,dy real idx,idy call textsize(form,0,labsiz,chrdelx,chrdely,0) goto (10,11,12,13),rotv/90+1 10 continue xb=xa0 yb=org tb=xa0 te=xa1 dx=dt dy=0.0 idx=0 del=-3.0+del-chrdely idy=del+chrdely/2 goto 14 11 continue xb=org yb=ya0 tb=ya0 te=ya1 dx=0.0 dy=dt del=-2.0+del-chrdelx idx=del+chrdelx/2 idy=0 goto 14 12 continue xb=xa0 yb=org tb=xa0 te=xa1 dx=dt dy=0.0 idx=0 idy=3.0+del+chrdely/2 del=3.0+del+chrdely goto 14 13 continue xb=org yb=ya0 tb=ya0 te=ya1 dx=0.0 dy=dt idx=2.0+del+chrdelx/2 del=del+2.0+chrdelx idy=0 14 continue 100 continue call text(conv(tb,form),xb,yb,idx,idy,0,labsiz,1) xb=xb+dx yb=yb+dy tb=tb+dt if(tb.lt. te+dt/2) goto 100 return end subroutine axtag(org,rotv,axlabl,del,labsiz) common/axiscom/xa0,ya0,xa1,ya1 real org,del,labsiz integer rotv character*(*)axlabl if (axlabl.gt.' ') then call textsize(axlabl,rotv,labsiz,chrdelx,chrdely,0) goto (10,11,12,13),rotv/90+1 10 call text(axlabl,(xa0+xa1)/2,org, $ 0.,del-3.0-chrdely/2,0,labsiz,1) goto 14 11 call text(axlabl,org,(ya0+ya1)/2, $ del-chrdelx/2-1.0,0.,90,labsiz,1) goto 14 12 call text(axlabl,(xa0+xa1)/2,org, $ 0.,del+3.0+chrdely/2,0,labsiz,1) goto 14 13 call text(axlabl,org,(ya0+ya1)/2, $ del+chrdelx/2+1.0,0.,90,labsiz,1) 14 continue endif return end