	character*80 f1
	character*60 ff(169)
	integer*2 map(99,99)
	logical logi
        inquire(file='batc.tmp',exist=logi)
        if(.not.logi)then
          write(*,*)
	  write(*,*)'   DISPLAY BATC_DATA star (99*99)*******2000.7'
	  write(*,*)
	  write(*,*)'                files <=169'                
          stop
        endif

	open(2,file='batc.tmp',status='old')
	read(2,'(a)')f1
	write(*,*)f1
	m4=0
5       m4=m4+1
        if(m4.gt.169)goto 6
        read(2,'(a)',end=6)ff(m4)
	goto 5
6	m4=m4-1
	close(2)

	call pgbegin(0,'/xw',1,1)
	call pgpap(8.54,1.015)
	call pgsci(0)
	call pgenv(1.,0.,1.,0.,1,1)
        epoch=2000.
100     write(*,21)epoch
21      format(' input alpha delta [',f6.1,']')
        read(*,'(a)')f1
        call itohd(f1,alpha,delta,xx)
        if(xx.ne.0.)epoch=xx
        call astprs(alpha,delta,epoch,alpha,delta,2000.)

	ii=3
	jj=3
	do 50 i=1,m4
	f1=ff(i)
 	k=index(f1,' ')-1
	f1='/base/'//f1(1:k)
	call getblock(f1,alpha,delta,map)
	k=49
	call turnx2(map,k,k,-180)
	call pgximage2(map,49,ii,631-jj,0.,15.)
	ii=ii+52
	if(ii.gt.630)then
	  ii=3
	  jj=jj+52
	endif
50	continue
	goto 100
	end

	subroutine getblock(f1,alpha,delta,ma)
	integer*2 map(25,25),ma(49,49)
	integer*2 b(512,512)
	byte c256(512*256),table(17)
	character*80 f1,head(36)
	real*8 a8(8)
	call getdata(f1,head,b,n,n1,n2,m1,m2,table)
	do 11 i=1,8
11	read(head(i+16)(12:),*)a8(i)
	call ujcomp(b,c256,table,n,m1,m2)
        call ucomp4(c256,b,m1,m2)
        iturn=0
        read(head(8)(25:),'(i2,1x,i2)')i,j
        if(j*10+i.ge.945.or.j.lt.90)iturn=1
	if(iturn.eq.1)call turnx2(b,m1,m2,-360)
	if(iturn.eq.0)call turnx2(b,m1,m2,-180)
	call ad2xy(a8,alpha,delta,x,y)
	ix=nint(x*0.25)-13
	iy=nint(y*0.25)-13

	do 10 i=1,25
	do 10 j=1,25
	map(i,26-j)=0
	ii=i+ix
	jj=j+iy
	if(ii.lt.1 .or. ii.gt.512)goto 10
	if(jj.lt.1 .or. jj.gt.512)goto 10
	map(i,26-j)=b(ii,jj)
10	continue
	call zoom(map,ma,25)
c	call zoom(b,ma,49)
	end

	subroutine zoom(a,b,n)
	integer*2 a(n,n),b(n+n-1,n+n-1)
	do 10 i=1,n
	k=i+i-1
	do 10 j=1,n
10	b(k,j+j-1)=a(i,j)
	m=n+n-1
	do 20 i=1,m,2
	do 20 j=2,m,2
20	b(i,j)=(b(i,j-1)+b(i,j+1))*.5
	do 30 i=2,m,2
	do 30 j=1,m,2
30	b(i,j)=(b(i-1,j)+b(i+1,j))*.5
	do 40 i=2,m,2
	do 40 j=2,m,2
40	b(i,j)=(b(i-1,j-1)+b(i-1,j+1)+b(i+1,j-1)+b(i+1,j+1))*.25+0.5
	end

	subroutine ad2xy(a8,alpha,delta,x,y)
	real*8 a8(8),adcoef(2,3)
	real*8 xa,xd,xi,xn,pi,cx,cy
        pi=4.*datan(1d0)
        cx=pi/12.
        cy=pi/180.
	call xy2ad(a8,adcoef)
        xa=alpha*cx
        xd=delta*cy
        call d_standc(a8(7),a8(8),xa,xd,xi,xn)
        x=adcoef(1,1)*xi+adcoef(1,2)*xn+adcoef(1,3)
        y=adcoef(2,1)*xi+adcoef(2,2)*xn+adcoef(2,3)
c	x=2049.-x
	y=2049.-y
	end

        subroutine xy2ad(x,a)
c 2 set 6 plate coef convert
        real*8 x(2,3),a(2,3),z
        z=x(1,1)*x(2,2)-x(1,2)*x(2,1)
        a(1,1)=x(2,2)/z
        a(1,2)=-x(1,2)/z
        a(1,3)=(x(1,2)*x(2,3)-x(1,3)*x(2,2))/z
        a(2,1)=-x(2,1)/z
        a(2,2)=x(1,1)/z
        a(2,3)=(x(1,3)*x(2,1)-x(1,1)*x(2,3))/z
        end

        subroutine d_standc(rc,dc,ra,de,xi,xn)
c alpha delta --------> X Y
c rc dc : center of plate
c rc dc ra de in arc
	real*8 rc,dc,ra,de,xi,xn,tmp
        sd=dsin(dc)
        cd=dcos(dc)
        td=dtan(de)
        co=dcos(ra-rc)
        tmp=sd*td+cd*co
        xi=dsin(ra-rc)/tmp
        xn=(cd*td-sd*co)/tmp
        end

	subroutine ujcomp(a,b,table,n,m1,m2)
	byte a(n),b(512*256),table(17)
	integer pb,pc,pa
	common /pca/pc,pa
	pc=0
	pa=0
	mm=m1*m2/2
	pb=0
10	pb=pb+1
	if(pb.gt.mm)return
	k=kgetbit(1,a)
	if(k.eq.0)then
	  b(pb)=0              ! 0
	  goto 10
	endif	
	k=kgetbit(2,a)
	if(k.lt.3)then
	  b(pb)=table(k+1) 	! 3 3_data
	  goto 10
	endif	
  	k=kgetbit(1,a)
  	if(k.eq.0)then
    	  b(pb)=kgetbit(8,a)  	! 4 for char 
	  goto 10
	endif	
  	k=kgetbit(2,a)
  	j=3
  	if(k.lt.2)then
    	  b(pb)=table(j+k+1)     ! 6 2_data 
	  goto 10
	endif	
20	j=j+2
  	if(j.eq.15)then
	  b(pb)=table(j+m+1)
	  goto 10
	endif	
  	m=kgetbit(1,a)
  	if(k.eq.2)then
	  b(pb)=table(j+m+1)
	  goto 10
	endif	
	if(m.eq.0)k=2
	goto 20
	end

        subroutine ucomp4(c,b,m1,m2)
        integer*2 b(512*512)
        byte c(512*256)
        i=1
        do 10 j=1,m1*m2/2
        k=c(j)
        if(k.lt.0)k=k+256
        j1=k/16
        j2=mod(k,16)
        b(i)=j1
        b(i+1)=j2
10      i=i+2
        end

	function kgetbit(m,a)
	byte a(1)
	integer pc,pa
  	integer*2 i,k
	byte c
	common /pca/pc,pa
  	k=0
	do 10 i=1,m
    	if(pc.eq.0)then
	  pa=pa+1
	  c=a(pa)
	endif
	k=k+k
        if(c.lt.0)k=k+1
	c=c+c
	pc=pc+1
10	if(pc.eq.8)pc=0
	kgetbit=k
	end

	subroutine getdata(f1,head,b,n,n1,n2,m1,m2,table)
	character*80 f1,head(36)
	byte b(1),table(17)
	open(3,file=f1,status='old',access='direct',recl=2880)
	read(3,rec=1)head
	close (3)
	read(head(3)(67:),*,err=10)n
	read(head(4)(20:),*)n1
	read(head(4)(69:),*)m1
	read(head(5)(20:),*)n2
	read(head(5)(69:),*)m2
	open(3,file=f1,status='old',access='direct',recl=2897+n)
	read(3,rec=1)head,table,(b(i),i=1,n)
	close(3)
10	return 
	end
