c---- tstcon.for	sg demo				21-jan-82
c
c  test sglib contour routines
c
	program contour
	integer   ipole
	character back*1
c
	ipole = 0
	call at_bint('Number of poles plots',ipole,back)
	do n=1,ipole
	  call poles
	enddo
c
#ifdef __VMS
	call at_bint('Number of ufile plots',iuf2,back)	
	do ii=1,iuf2		
	  call uplot		
	enddo
#endif		
c
	end
c%
	subroutine poles
c
c---- this contour plot was submitted by hedi selberg.
c
	parameter (mx=51)
	parameter (my=101)
	real x(mx),y(my),th(mx),rr(my)
	real x2(mx,my),y2(mx,my),a(mx,my),c(40)
cx	integer kolors(6) /2,3,4,5,6,7/
	integer icall
	real cfirs
	integer nx, ny
	data icall /1/
	data cfirs /-.05/
	data nx /12/, ny /12/

	external polpro
c
	call at_int('Rcontr (1), Contur (2)',icall)
	call at_real('First contour level',cfirs)
	call at_int('Number of x points',nx)
	call at_int('Number of y points',ny)
	p2=6.2831852
	dx=1./nx
	do i=1,nx
	  x(i)=p2*i*dx
	enddo
	dy=1./ny
	do j=1,ny
	  y(j)=p2*j*dy
	enddo
	dr=1./(ny)
	dth=p2/(nx)
	do j=1,ny
	  yy=p2*(j)*dy
	  rr(j)=(j)*dr
	  do i=1,nx+1
	    th(i)=(i-1)*dth
	    xx=p2*(i)*dx
	    a(i,j)=sin(yy)*cos(xx)
	    x2(i,j)=rr(j)*cos(th(i))
	    y2(i,j)=rr(j)*sin(th(i))
	  enddo
	enddo
c
	call initt(120)
cx	call binitt
cx	call slimx(150,750)	!default is 150,900
cx	call slimy(100,500)	!default is 125,700
cx	call agrcfr(x,1,nx,2,y,1,ny,2,1)
	c(1)=cfirs	!first solid (fnc min = -2.05)
	c(2)=.1		!increment
	k1=0		!c(1)=f0, c(2)=df, z<c(1) is dotted
	k2=0
	if(icall.eq.1) then
	  call agraph(150,750,100,500,
     >		x(1),x(nx-1),y(1),y(ny-1),'X','Y')
	  call rcontr(k1,c,k2,a,mx,x,1,nx,2,y,1,ny,2)
	elseif(icall.eq.2) then
	  xmax=rr(ny)*.8
	  call agraph(150,750,100,500,
     >		-xmax,xmax,-xmax,xmax,'X','Y')
	  call contur(k1,c,k2,a,mx,x2,1,nx+1,1,y2,1,ny,1)
	elseif(icall.eq.3) then
	  xmax=rr(ny)*.8*.6
	  call agraph(150,750,100,500,
     >		-xmax,xmax,-xmax,xmax,'X','Y')
	  call contur(k1,c,k2,a,mx,x2,1,nx+1,1,y2,1,ny,1)
	endif
	call agxmhs(350,600,'POLES: A CONTOUR PLOT$')
	call upause(0)
	call finitt(0,0)
	return
	end
	subroutine polpro(x,y,px,py)
	px=y*cos(x)
	py=y*sin(x)
	end
c%
#ifdef __VMS
	subroutine uplot 
	parameter (mxd=16384) 
	real xdata(mxd),ydata(mxd) 
	real zdata(*), tdata(*) 
	pointer (azdat,zdata), (atdat,tdata) 
	parameter (mc=20) 
	parameter (irit=802) 
	parameter (itop=680) 
	real cont(mc) 
	integer info(8) 
	logical lrot 
	character fspec*48,fpref*24,fextn*4,fdisk*24,farea*24,fshot*5 
	character back*1,cvalu*12 
	character zop*1 /'A'/ 
	integer k1 /8/

	integer lib$get_vm, lib$free_vm
 
	data fspec /'FM_RES:[TFTR.FM]A44008.FMA'/ 
c 
	call at_char('File spec',fspec) 
	call ufspec(fspec,fpref,fextn,fdisk,farea,fshot,jshot) 
	call ufimsg(0) 
	call ufsetr(8,fpref,fextn,fdisk,farea) 
	call ufoprd(8,jshot,ier) 
	call ufhdck(8,info,ier) 
	if(ier.ne.0) then 
	  call at_msgi('cant open file',ier) 
	  return 
	endif 
	if(info(1).ne.2) then 
	  call at_msgi('Ufile dimensionality =',info(1)) 
	  ier=99 
	  return 
	endif 
	call at_msgi('  x points',info(3)) 
	call at_msgi('  y points',info(4)) 
	call at_blog('Rotate',lrot,back) 
	lrsize=sizeof(tdata(1)) 
	if(lrot) then 
	  mxa=info(4) 
	  mya=info(3) 
	  igood = lib$get_vm(mxa*mya*lrsize,atdat) 
	else 
	  mxa=info(3) 
	  mya=info(4) 
	endif 
	igood = lib$get_vm(mxa*mya*lrsize,azdat) 
	if(.not.igood) then
          type *,'call lib$signal' 
	  call lib$signal(%val(igood)) 
	endif 
	if(lrot) then 
	  call uf2dre(8,tdata,mya,ydata,mya,xdata,mxa,ny,nx,0,ier,0) 
	  jj = 1 
	  do ii=1,ny 
	    call jc_amovs(tdata(ii),zdata(jj),nx,ny) 
	    jj = jj+nx 
	  enddo 
	  igood = lib$free_vm(mxa*mya*lrsize,atdat) 
	else 
	  call uf2dre(8,zdata,mxa,xdata,mxa,ydata,mya,nx,ny,0,ier,0) 
	endif 
	call ufclos(8) 
	kxst=max(nx/20,1) 
	call at_int('X step',kxst) 
	kyst=max(ny/20,1) 
	call at_int('Y step',kyst) 
	scale=1. 
	call at_real('Z scale',scale) 
	if(scale.ne.1.) then 
	  jaz = azdat 
	  do ii=1,ny 
	    call jc_afac(scale,%val(jaz),nx) 
	    jaz = jaz+(nx)*4 
	  enddo 
	endif 
c 
	call jc_amnmx(zdata,mxa*mya,zmin,zmax) 
	call at_int('Number of contour lines',k1) 
	if(k1.eq.0) then 
	  call at_int('Number of levels',ncont) 
	  k2=0		!not used 
	  cont(1)=zmin 
	  cont(2)=(zmax-zmin)/ncont 
	elseif(k1.lt.0) then 
	  call at_real('Data min',zmin) 
	  call at_real('Data max',zmax) 
	  cont(1)=zmin 
	  cont(2)=zmax 
	  call at_int('Number of dashed lines',k2) 
	  ncont=-k1 
	else			!k1>0 
	  zdelt=(zmax-zmin)/k1 
	  call at_real('Data min',zmin) 
	  call at_real('Data del',zdelt) 
	  call at_char('Add or Multiply',zop) 
	  if(zop.eq.'M') then 
	  cont(1)=zmin 
	  do i=2,k1 
	    cont(i)=cont(i-1)*zdelt 
	  enddo 
	  else 
	  do i=1,k1 
	    cont(i)=zmin+(i-1)*zdelt 
	  enddo 
	  endif 
	  call at_int('Number of dashed lines',k2) 
	  ncont=k1 
	endif 
c 
	call initt(120) 
	call binitt 
	call slimx(222,irit) 
	call slimy(100,itop) 
	call agrcfr(xdata,1,nx,kxst,ydata,1,ny,kyst,2) 
	call rcontr(k1,cont,k2,zdata,mxa, 
     >		xdata,1,nx,kxst,ydata,1,ny,kyst) 
	call agtchs('X') 
	call agtcvs('Y') 
	ixl = irit+20	!right edge +20 
	iyl = itop	!top edge 
	iht=linhgt(1) 
	do i=1,ncont 
	  iyl = iyl-iht	!move down one line 
	  call movabs(ixl,iyl) 
	  write (cvalu,'(1pe9.2)') cont(i) 
	  call agths(cvalu) 
	enddo 
	call upause(0) 
	call finitt(0,0) 
	igood = lib$free_vm(mxa*mya*lrsize,azdat) 
	return 
	end 
c% 
	subroutine jc_amovs(xy,y,nw,mx) 
	real xy(mx,*),y(*) 
	do j=1,nw 
	  y(j)=xy(1,j) 
	enddo 
	end 

        subroutine jc_afac(c,a,n)       !multiply a by constant
        real a(*)
        do i=1,n
          a(i)=a(i)*c
        enddo
        end
 
        subroutine jc_amnmx(a,n,a1,a2)  !find minimum and maximum  !01/15/85
        real a(*)
        t1=a(1)         !faster than using a1/a2 inside loop
        t2=t1
        do i=2,n
          t1=min(t1,a(i))
          t2=max(t2,a(i))
        enddo
        a1=t1
        a2=t2
        end
#endif
