%include "iff:iffinc.imp"
%include "edwin:consts.inc"
%include "edwin:types.inc"
%include "edwin:shapes.inc"
%include "edwin:specs.inc"
%include "inc:maths.imp"
%include "inc:util.imp"
%begin
%record (iffhdr fm) iffh
%externalstring(255 ) inpfn,outfn,out,textstring,infile,outfile,ss,tt
%externalreal base,increment,temp
%externalreal scale=500000,radius=1,constraint,r,xmax,ymax,f,step,t,critical=10000
%externalinteger labon=0,laboff=1,
         on=1,off=0,true=1,false=0,auto=1,baseplus=2,user=3
%externalinteger i,mi,mj,labtype=0,ch,buttons=0,tx,ty,basex=10,basey=10,sizex=800,
         sizey=800,
         font=0,textsize=12,error,low=3,high=1,nconts=10,kolour=yellow,contselect=1, 
         resolution=40,smoothing=1,smoothres=2,interpolation=1,
         j,flag,count,x,y,itemp,
         istep,accept=0,total=0,key declared=0
%recordformat crf(%real val,%string(255) str)
%externalrecord(crf) %array cont map(1:20)

%integerfn integerpt(%real x)
  %if x<0 %then x=x+1
  %result=intpt(x)
%end


%string(255)%fn realtostring(%real x)  
%byte negative,fraction,l
%real h  
%integer exponent,texponent,sizeexp,length,size,test
%string(255) oust,label,a,b,c,d,exp

%routine trailing zeroes
%on %event 7 %start
 ->label
%finish
a=oust
a->b.(".").d
%cycle
  c=substring(d,l,l)
  %if c="0" %start
    d=substring(d,1,l-1)
     l=l-1
    length=length-1
  %finish
%repeat %until c<>"0"   
label:
  %if (d="") %start
    oust=b
    length=length-1
  %else
    oust=b.(".").d
  %finish
%end


%routine formstring
  negative=false
  fraction=false
  h=x
  %if h<0 %start
    h=-(h)
    negative=true
  %finish
  %if h<1 %start
    %if h<>0 %start
      h=1/(h*10)
      fraction=true
    %finish
  %finish
  %if (h>=1000000) %or ((fraction=true) %and (h>1000)) %start
    exponent=0
    %while h>=10 %cycle
      h=h/10
      exponent=exponent+1
    %repeat
    sizeexp=1
    texponent=exponent
    %while texponent>=10 %cycle
      texponent=texponent//10
      sizeexp=sizeexp+1
    %repeat
    %if fraction=true %then oust=rtos(10/h,1,2) %else oust=rtos(h,1,2)
    l=2
    length=4
    trailing zeroes
    exp=itos(exponent,sizeexp)
    oust->(" ").oust
    exp->(" ").exp
    %if negative=true %start
      %if fraction=true %start
         label="-".oust."E-".exp
      %else
         label="-".oust."E".exp
      %finish
    %else
      %if fraction=true %start
         label=oust."E-".exp
      %else
         label=oust."E".exp
      %finish
    %finish
  %else
    %if fraction=true %start
      oust=RtoS(x,1,4)
      oust->(" ").oust %if negative=false
      length=6
      l=4
      trailing zeroes
    %else
      size=0
       %cycle
         size=size+1
         h=h/9.9999999
         test=intpt(h)
       %repeat %until test=0
       length=7
       oust=rtos(x,size,6-size)
       l=6-size
       oust->(" ").oust %if negative=false    
       %if size<>6 %then trailing zeroes
    %finish
    %if negative=true %start
      label=oust
    %else
      label=oust
    %finish
  %finish

%end

  formstring
  %result=label
%end

%routine clear 
  printsymbol(27)
  printsymbol('v')
%end
 
%routine arrange coords(%integer par1,par2,%integer %name one,two)
%integer temp
  %if one<0 %then one=0
  %if one>1024 %then one=1024
  %if two<0 %then two=0
  %if two>1024 %then two=1024
  %if one>two %start
    temp=two
    two=one    
    one=temp
  %finish
%end

%routine drawbox(%integer x1,y1,x2,y2)
  moveabs(x1,y1)
  line abs(x2,y1)
  line abs(x2,y2)
  line abs(x1,y2)
  line abs(x1,y1)
%end
  
%routine drawscreen
!KCN! klear
{JHB} clear
   initialise for(default device)
   newframe
   set colour(black)
   drawbox(basex,basey,sizex,sizey)
%end


%routine normalise(%realname val,%integer places)
%real lower=10^(places-1),upper=10^places,arg=val
%integer exp=0,intarg
%if arg<0 %then arg=-(arg)
%if arg#0 %start
%if arg<lower %start
   %cycle
      arg=arg*10
      exp=exp-1
!     newline
   %repeat %until arg>lower
%else %if arg>upper
   %cycle 
!      printsymbol('8')
      arg=arg/10
      exp=exp+1
   %repeat %until arg<upper
%finish
%finish
%if val<0 %then arg=-(arg)
intarg=intpt(arg)
%if intarg<30 %then intarg=5*((intarg+5)//5) %else intarg=10*((intarg+10)//10)
val=(intarg) *10^exp
%end

%routine contlab(%integer file, ad)
  %constantbyteinteger up=8,
                       down=4,
                       left=2,
                       right=1,
                       interpolated=0,
                       notinterpolated=1,
                       typea=1,
                       typeb=0
  %byte finished,
        startdir,
        startvis=1,
        inside,
        orientation,
        source,
        dest,
        z
  %string(255) label
  %real sourcex,sourcey,aveheight,h,
            maxdiff,
            xscale=(sizex-basex)/(mi-1),
            yscale=(sizey-basey)/(mj-1),
            maxlen=sqrt((xscale*xscale)+(yscale*yscale)),
            ymult=1,
            deltad  
  %integer c,j,
           ti,tj,
           startx,starty,starti,startj,
           markerx,
           markery,
           nosegments=0,
           linelength=0,
           destx,
           desty,
           labsize,
           ydiff=0,
           maxhoriz=intpt((textsize*(0.8))/xscale)+1,
           maxvert= intpt((textsize*(0.8))/xscale)+1 
  %bytearray skeleton(0:mi,0:mj)
  %recordformat linef(%integer x,y,sx,sy,drawn,%byte dir,%real ccos,csin)
  %record(linef) %array linedata(0 :20000)
  %realarray main(1:mi,1:mj)


%routine readarray(%integer ad)
  %integer x,y
  %recordformat rf(%real r)
  %record (rf) %name r
  %if iffh_datatype & 7 = 0 %start ;!bytes
     %for y=mj,-1,1 %cycle; %for x=1,1,mi %cycle
        main(x,y) = byteinteger(ad); ad=ad+1
     %repeat; %repeat
  %elseif iffh_datatype & 7 = 1 ;!16-bit words
     %for y=mj,-1,1 %cycle; %for x=1,1,mi %cycle
        main(x,y) = halfinteger(ad); ad=ad+2
     %repeat; %repeat
  %elseif iffh_datatype & 7 = 5 ;!32-bit reals
     r == record(ad)
     %for y=mj,-1,1 %cycle; %for x=1,1,mi %cycle
         main(x,y)= r_r; r == r[1]
     %repeat; %repeat
  %finish
%end


%routine readandset(%integer ad)
%integer x,y
%real max=-10@32,min=10@32,z
  readarray(ad)
  %for y=mj,-1,1 %cycle
    %for x=1,1,mi %cycle
      z=main(x,y)
      %if z>max %start
        max=z
      %else %if z<min
        min=z
      %finish
    %repeat
  %repeat
  increment=(max-min)/nconts
  normalise(increment,2)
  base=min
  min=min-(increment/2)
  min=intpt((min/increment)+1)*increment
nconts=0
%cycle
   nconts=nconts+1
   contmap(nconts)_val=min
   contmap(nconts)_str=realtostring(contmap(nconts)_val)
   min=min+increment
%repeat %until min>max
!printstring("read")
%end



%routine zerskel
%integer x,y
  %for y=0,1,mj %cycle
    %for x=0,1,mi %cycle
       skeleton(x,y)=0
    %repeat
  %repeat
%end

%routine setup(%integer ad)
  %realarray diff(1:8)
  %real a,b,total,thirdcrit,o
  %integer i,j,k,flags=0
  %if contselect=auto %then readandset(ad) %else readarray(ad)
  thirdcrit=critical/4
  labsize=textsize
!  %if labsize>20 %then labsize=20
  %if labsize<1 %then labsize=1
  %if maxhoriz>1 %or maxvert>1 %start
    maxdiff=1
  %else
    a=(((sizex-basex)/mi)/(2*nconts))*(12/labsize)
    b=(((sizey-basey)/mj)/(2*nconts))*(12/labsize)
    %if a<b %then b=a
    maxdiff=intpt(b)
    %if maxdiff=0 %then maxdiff=1
  %finish
  SETCOLOUR(kolour)
  set char quality(1)
  set char font(11)
  set char size(labsize)
  zerskel
  %if smoothing=on %start
  %for i=1,1,mi   %cycle
    %for j=1,1,mj   %cycle
      total=0
      o = main(i,j)
      
      diff(k)=0 %for k=1,1,8 
      %if i#1  %and j#1  %then diff(1) = o-main(i-1,j-1) %else diff(1) = o-base
      %if i#1  %and j#mj %then diff(2) = o-main(i-1,j+1) %else diff(2) = o-base
      %if i#mi %and j#1  %then diff(4) = o-main(i+1,j-1) %else diff(3) = o-base
      %if i#mi %and j#mj %then diff(3) = o-main(i+1,j+1) %else diff(4) = o-base
      %if j#1            %then diff(5) = o-main(i,  j-1) %else diff(5) = o-base
      %if j#mj           %then diff(6) = o-main(i,  j+1) %else diff(6) = o-base
      %if i#mi           %then diff(7) = o-main(i+1,  j) %else diff(7) = o-base
      %if i#1            %then diff(8) = o-main(i-1,  j) %else diff(8) = o-base

      %for k=1,1,8 %cycle
         %if diff(k)<0 %then diff(k)=-(diff(k))
         %if diff(k)>thirdcrit %then diff(k)=critical+1
         total=total+diff(k)
      %repeat
      %if total>critical %start
         skeleton(i,j)=skeleton(i,j)+16
         flags=flags+1
      %finish
    %repeat
  %repeat
  %finish
    ymult=1
    ydiff=0
  maxvert=intpt(maxvert/ymult)
  %if maxvert=0 %then maxvert=1
!printstring("setup")
%end



%routine drawto(%integer segment)
!%on %event 0,1,2,3,4,5,6,7,8,9 %start
!->finito
!%finish
   %if linelength#0 %then moveabs(linedata(linelength)_x,linedata(linelength)_y)
   %while linelength<segment %cycle
    linelength=linelength+1
      line abs(linedata(linelength)_x,linedata(linelength)_y)
  %repeat
!  newline
finito:
%end


%routine quangl(%integer point)
%integer a,b,c,d           
%real e,coss,sine
%integerarray t(1:3)
%on %event 1 %start
%finish
  a=linedata(point)_x-linedata(point-1)_x
  b=linedata(point)_y-linedata(point-1)_y
  c=linedata(point+1)_x-linedata(point)_x
  d=linedata(point+1)_y-linedata(point)_y
  t(1)=(a*a)+(b*b)
  t(3)=(c*c)+(d*d)
  coss=a*t(3)+c*t(1)
  sine=b*t(3)+d*t(1)
  e=(sqrt(coss*coss+sine*sine))
  %if e=0 %then e=1 %else e=1/e
  linedata(point)_ccos=coss*e
  linedata(point)_csin=sine*e
end:
%end

%routine save2(%integer x,y,drawn)
 %if nosegments=0 %then ->l
   %if x#linedata(nosegments)_x %or y#linedata(nosegments)_y %start
 %if nosegments=1 %then ->l
   %if x#linedata(nosegments-1)_x %or y#linedata(nosegments-1)_y %start
l:
     nosegments=nosegments+1
     linedata(nosegments)_drawn=drawn
     linedata(nosegments)_x=x
     linedata(nosegments)_y=y
     linedata(nosegments)_sx=ti
     linedata(nosegments)_sy=tj
     linedata(nosegments)_dir=dest
   %finish
   %finish
%end


%routine save(%integer x,y,drawn)
%integer nosegs   
%real xinc,yinc,x1,y1,len
%if nosegments#0 %start
    %if smoothing=on %and skeleton(ti,tj)>15 %start
      len=sqrt(((linedata(nosegments)_x-x)^2)+((linedata(nosegments)_y-y)^2))
      nosegs=intpt((len/maxlen)*5)+2
!      printsymbol(nosegs+48)
      %if nosegs>2 %start
      xinc=(x-linedata(nosegments)_x)/(nosegs)
      yinc=(y-linedata(nosegments)_y)/(nosegs)
      x1=linedata(nosegments)_x
      y1=linedata(nosegments)_y
      nosegments=nosegments-1 %unless nosegments=1
      %for i=1,1,nosegs-1 %cycle
        x1=(x1+xinc)
        y1=(y1+yinc)
        save2(intpt(x1+0.5),intpt(y1+0.5),drawn)
      %repeat
      %else
        save2(x,y,drawn)
      %finish
  %finish
%finish
  save2(x,y,drawn)
%end

%routine quarc(%integer i2,deltas,ifull)
%real c1,c2,s1,s2,a,b,c,e,f,g,h,t,u,v
%integer delssq,x1,x2,y1,y2,i,j,k,m,n
 %if i2>2 %start
   delssq=deltas*deltas
   m=ifull+3
   i=1
   k=1
   ->q1
q4:
   x1=x2
   y1=y2
   c1=c2
   s1=s2
q1:
   x2=linedata(k)_x
   y2=linedata(k)_y
   e=linedata(k)_ccos
   f=linedata(k)_csin
   b=1/sqrt(e*e+f*f)
   c2=b*e
   s2=b*f
   %if i=1 %then ->q2               
q3:
   u=x2-x1
   v=y2-y1
   g=u*u+v*v
   a=c1*c2+s1*s2
   j=1
   %if g>=delssq %then ->q11
   %if g>0 %then ->q5
   %if a>0.99996 %then ->q5 %else ->q10
q11:
   a=7-a
   e=c1+c2
   f=s1+s2
   b=u*e+v*f
   t=sqrt(b*b+2*a*g)
   c=(t+b)/g
   t=3*(t-b)/a
   g=c/12
   a=g*(c*u-3*e)
   b=g*(c*v-3*f)
   u=g*(c2-c1)+a
   v=g*(s2-s1)+b
   c=(-c)/9
   a=a*c
   b=b*c
   g=h
q9:
   e=g*(g*(a*g+u)+c1)+x1
   f=g*(g*(b*g+v)+s1)+y1
   lineabs(intpt(e),intpt(f))
   n=m-n
   g=g+deltas
   h=g-t
   %if h>0 %then ->q13 %else ->q9
q2:
   moveabs(x2,y2)
   i=2
q6:
   h=deltas
   n=2
q13:
   j=2
q5:
   k=k+1
    %if k>i2 %then ->q10                 
q12:
   %if j=1 %then ->q1 %else ->q4
q10:
   lineabs(x2,y2)
   %if j=1 %then ->q6                 
%else
  %if i2=1 %then markerabs(0,linedata(1)_x,linedata(1)_y)
  %if i2=2 %start
      moveabs(linedata(1)_x,linedata(1)_y)
      lineabs(linedata(2)_x,linedata(2)_y)
  %finish
%finish
%end  

%routine mark x points
  %integer i,j,a,b,c
  %for i=1,1,mi %cycle
    %for j=1,1,mj %cycle
      %if main(i,j)>h %start
         skeleton(i,j)=skeleton(i,j)+32
      %finish %else skeleton(i,j)=skeleton(i,j)&2_00010000
      %if main(i,j)=h %then printsymbol('=')
      %if main(i,j)=h %then main(i,j)=main(i,j)-0.5*increment
    %repeat
  %repeat
  %for i=1,1,mi-1 %cycle
    %for j=1,1,mj-1 %cycle
      a=skeleton(i,J)&2_00100000
      b=skeleton(i,j+1)&2_00100000
      c=skeleton(i+1,j)&2_00100000
      %if a+b=32 %start
        skeleton(i,j)=skeleton(i,j)!left
        skeleton(i-1,j)=skeleton(i-1,j)!right
      %finish
      %if a+c=32 %start
        skeleton(i,j)=skeleton(i,j)!down
       skeleton(i,j-1)=skeleton(i,j-1)!up
      %finish
    %repeat
  %repeat
  %for i=1,1,mi-1 %cycle
    %if  skeleton(i+1,mj)&2_00100000+skeleton(i,mj)&2_00100000 =32 %start
      skeleton(i,mj)=skeleton(i,mj)!down
      skeleton(i,mj-1)=skeleton(i,mj-1)!up  
    %finish
  %repeat
  %for j=1,1,mj-1 %cycle
    %if skeleton(mi,j+1)&2_00100000+skeleton(mi,j)&2_00100000=32 %start
      skeleton(mi,j)=skeleton(mi,j)!left
      skeleton(mi-1,j)=skeleton(mi-1,j)!right
    %finish
  %repeat
  %for i=0,1,mi  %cycle
    %for j=0,1,mj %cycle
      skeleton(i,j)=skeleton(i,j)&2_00011111                
    %repeat
  %repeat
%end

%integerfunction trans2(%integer desty)
   %result=intpt(desty*ymult+ydiff)
%end

%routine connect
  %integer yscal=intpt(yscale),xscal=intpt(xscale)
! printsymbol(source+48)
! printsymbol(dest+48)
  %if dest#0 %start
    %if dest=left %start
      deltad=(h-main(ti,tj))/(main(ti,tj+1)-main(ti,tj))
      destx=int pt(ti*xscale)-xscal
      desty=int pt((tj+deltad)*yscale)-yscal
    %else %if dest=right
      deltad=(h-main(ti+1,tj))/(main(ti+1,tj+1)-main(ti+1,tj))
      destx=intpt((ti+1)*xscale)-xscal
      desty=int pt((tj+deltad)*yscale)-yscal
    %else %if dest=up
      deltad=(h-main(ti,tj+1))/(main(ti+1,tj+1)-main(ti,tj+1))
      destx=int pt((ti+deltad)*xscale)-xscal
      desty=intpt((tj+1)*yscale)-yscal
    %else %if dest=down
      deltad=(h-main(ti,tj))/(main(ti+1,tj)-main(ti,tj))
      destx=int pt((ti+deltad)*xscale)-xscal
      desty=intpt(tj*yscale)-yscal
!   %else
!     printstring("Fault")
!     dest =left
    %finish
  %finish
  %if source#0 %start
    skeleton(ti,tj)=skeleton(ti,tj)-source
    skeleton(ti,tj)=skeleton(ti,tj)-dest
    %if smoothing=on %start
       save(destx+basex,trans2(desty)+basey,1)          
    %else
      line abs(destx+basex,trans2(desty)+basey)
    %finish
  %else
     %if inside=true %start
        startx=destx+basex
        starty=trans2(desty)+basey
      starti=ti
      startj=tj
      startdir=dest
      skeleton(ti,tj)=skeleton(ti,tj)-source
      skeleton(ti,tj)=skeleton(ti,tj)-dest
    %else
      skeleton(ti,tj)=skeleton(ti,tj)&2_00010000
    %finish
    %if smoothing=on  %start    
        save(destx+basex ,trans2(desty)+basey,1)          
     %else
       move abs(destx+basex,trans2(desty)+basey)
     %finish
  %finish
  %if dest=left %start
    source=right
    ti=ti-1
  %else %if dest=right
    source=left
    ti=ti+1
   %else %if dest=up
    source=down
    tj=tj+1
  %else %if dest=down
    source=up
    tj=tj-1
  %else  
!   printstring("Mistake")
    source=17
  %finish
%end
 
%routine trace contour
  %real aveheight
  %integer z
  %constbytearray taba(1:8) = up,down,0,left,0,0,0,right
  %constbytearray tabb(1:8) = down,up,0,right,0,0,0,left
  ti=markerx
  tj=markery
  sourcex=0
  sourcey=0
  source=0
  nosegments=0
  flag=0
  z=skeleton(ti,tj)&2_00001111
  %if inside=false %start
    dest=skeleton(ti,tj)&2_00001111
  %else %if z>8 
    dest=up
  %else %if z>4
    dest=down
  %else
    dest=left
  %finish
  connect
  z=skeleton(ti,tj)&2_00001111
  %while z#0 %cycle
    %if z=15 %start
      aveheight=(main(ti,tj)+main(ti,tj+1)+main(ti+1,tj)+main(ti+1,tj+1))/4
      %if main(ti,tj)>h %start
        %if aveheight<h %then dest = taba(source) %else dest = tabb(source)
      %else
        %if aveheight<h %then dest = tabb(source) %else dest = taba(source)
      %finish
    %else
      %if (z=8) %or (z=2) %or (source=0) %or (z=1) %or (z=4) %start
        dest=0
      %else
        dest=z-source
      %finish
    %finish
    connect
    Z=skeleton(ti,tj)&2_00001111
  %repeat
  %if inside=true  %start
    ti=starti
    tj=startj
    dest=startdir
    save (startx,starty,startvis)
  %finish
  %if smoothing=on %start
     %if inside=true %start
        linedata(0)=linedata(nosegments-1) 
        linedata(nosegments+1)=linedata(2)
     %else
        %if linedata(1)_sx=0 %start
            linedata(0)_x=linedata(1)_x-1
            linedata(0)_y=linedata(1)_y
        %else %if linedata(1)_sy=0
            linedata(0)_x=linedata(1)_x
            linedata(0)_y=linedata(1)_y-1
        %else %if linedata(1)_sx=mi
            linedata(0)_x=linedata(1)_x+1
            linedata(0)_y=linedata(1)_y
        %else
            linedata(0)_x=linedata(1)_x
            linedata(0)_y=linedata(1)_y+1
        %finish
        %if linedata(nosegments)_sx<2 %start
            linedata(nosegments+1)_x=linedata(nosegments)_x-1
            linedata(nosegments+1)_y=linedata(nosegments)_y
        %else %if linedata(nosegments)_sy=0
            linedata(nosegments+1)_x=linedata(nosegments)_x
            linedata(nosegments+1)_y=linedata(nosegments)_y-1
        %else %if linedata(nosegments)_sx>mi-2
            linedata(nosegments+1)_x=linedata(nosegments)_x+1
            linedata(nosegments+1)_y=linedata(nosegments)_y
        %else
            linedata(nosegments+1)_x=linedata(nosegments)_x
            linedata(nosegments+1)_y=linedata(nosegments)_y+1
        %finish
        %if linedata(0)_x=linedata(2)_x %and linedata(0)_y =    linedata(2)_y %c
        %then linedata(0)_x=linedata(0)_x-1
        %if linedata(nosegments-1)_x=linedata(nosegments+1)_x %and %c
        linedata(nosegments-1)_y=linedata(nosegments+1)_y %then %c
        linedata(nosegments+1)_x=linedata(nosegments+1)_x+1
      %finish
      quangl(j) %for j=1,1,nosegments
      nosegments=nosegments+1
{      nsegs=nosegments}
      quarc(nosegments-1,smoothres,3)
  %finish
  %if labtype=labon %and smoothing=off  %start
  %else %if (inside=true) %and (labtype=laboff) %and smoothing=off
       linelength=0
       nosegments=0
       drawto(1)
  %finish
%end

%routine find start point
  markerx=0
  markery=1
  finished=false
  inside=false
  trace contour %if skeleton(markerx,markery)&2_00001111#0
  %while finished=false %cycle
    %if inside=false %start
      %if (markerx=0) %and (markery=0) %start
        inside=true
        markerx=1
        markery=1
      %finish %else %if markery=0 %start
        markerx=markerx-1
      %else %if markerx=mi  
        markery=markery-1
      %else %if markery=mj 
        markerx=markerx+1
      %else 
        markery=markery+1
      %finish
    %else
      %if (markerx=(mi-1)) %and (markery=(mj-1)) %start
        finished=true
      %else %if markerx=(mi-1)
        markerx=1
        markery=markery+1
      %else
        markerx=markerx+1
      %finish
    %finish
    trace contour %if (skeleton(markerx,markery)&2_00001111)#0   
  %repeat
%end

setup(ad)
%for c= 1,1,nconts %cycle
  printsymbol('d')
  h=contmap(c)_val    
  label=contmap(c)_str
  mark x points
  find start point
%repeat
%end

%routine vector one(%string(255) output file name)
    labtype=laboff
    %if output file name#"" %start
       open output(2,output file name)
       store on(2)
    %finish
%end

   
%external %routine vector contours from file(%string(255) input file name, %c
                                                          output file name)
    %integer rc,ad
    iffh=0
    ad=0
    rc=iff readin(input file name, iffh, ad)
    mi = iffh_wid; mj=iffh_ht
    vector one(output file name)
    contlab(1, ad)
    heapput(ad)
    select output(0)
    storeoff
    select input(0)
%end

%external %routine set contour window(%integer a,b,c,d)                     
   basex=a
   basey=b
   sizex=c
   sizey=d
   %if basex>sizex %or basey>sizey %start
      printstring("ERROR faulty window definition:coordinates rearranged")
      arrange coords(2,4,basex,sizex)            
      arrange coords(3,5,basey,sizey)            
   %finish
%end

%external %routine automatic contour interval selection(%integer n)    
    nconts=n
    %if (nconts>20) %or (nconts<1) %start     
      printstring("ERROR Invalid number of contours")
      ->abort
    %finish
    cont select=auto
abort:
%end

%externalroutine base plus increment interval selection(%real b,i, %integer n)   
    %integer j
    base=b
    increment=i
    nconts=n
    cont select=baseplus
    %if nconts>20 %or nconts<1 %start
       printstring("ERROR Invalid number of contours")
    %else
       temp=base
       %for j=1,1,nconts %cycle
          contmap(j)_val=temp
          contmap(j)_str=(realtostring(temp))
          temp=temp+increment
       %repeat
    %finish
%end

%external %routine vector smoothness off
  smoothing=off
  smoothres=0
%end

%external %routine vector smoothness on(%integer smoothness)
  smoothing=on
  smoothres=smoothness
%end

%external %routine vector smoothness granularity off
  critical=10000000
%end

%external %routine vector smoothness granularity on(%real granularity)
  critical=granularity
%end

%external %routine set raster interpolation(%integer degree)
  %if degree>3 %or degree<1 %start
    Printstring("ERROR Raster interpolation value invalid")
    ->abort
  %finish
  %if degree=1 %then smoothing=off %else smoothing=on
  smoothres=degree
abort:
%end

  initialise for(default device)
  newframe
  window(0,1000,0,1000)
  set contour window(0,0,1000,1000) 
vector smoothness off
infile=cli param
to upper(infile)
%if infile -> infile.(".IFF") %start; %finish
outfile=infile %unless infile->infile.("/").outfile
outfile = outfile.".pdf" %unless outfile -> ss.(".").tt
vector contours from file(infile,outfile)
%endofprogram
