	character*30 f1,ch*1
	integer*2 b(512*512)
 	integer*2 a(8396*8301*2)		! -32 change to 16 when cal.

        write(*,*)
	write(*,*)' Usage: lookccd [number]'
        write(*,*)
        write(*,*)'        left_botton forward'
        write(*,*)'       right_botton backward'
        write(*,*)'     middlet_botton exit'
	write(*,*)

        i=iargc()
        k=1
        if(i.ne.0)then
          call getarg(1,f1)
          read(f1,*)k
        endif
        call system("ls *.fit *.ccd > /tmp/lookccd.tmp")
 	call pgbegin(0,'/xw',1,1 )
	call pgpap(7.0,1.015)
	call pgsci(0)
        call pgenv(1.,512.,512.,1.,0,0)
	call pgsci(1)
5	if(k.lt.1)k=1
        open(2,file='/tmp/lookccd.tmp',status='old')
        j=0
10	read(2,'(a)',end=20)f1
        j=j+1
	write(*,'(i3,2a)')j,':   ',f1
	if(k.gt.j)goto 10

        call inqh(f1,n1,n2,nhead,ibit,b0)
	if(n1.lt.512 .or. n2.lt.512)goto 10
	nhead=(nhead-1)/36+1
	ibit=ibit/8
	if(ibit.lt.0)ibit=-ibit
	length=n1*n2*ibit
        ipos=nhead*2880
	i=lnblnk(f1)+1
	f1(i:i)=char(0)
	call tvread(f1,a(1),length,ipos)
	f1(i:i)=char(32)
	call ch512(a,n1,n2,ibit,b,b0)
c main_job
	call main_job(b,f1,ch,j,n1,n2)
        if(ch.eq.'D')stop
        if(ch.eq.'X')then
          close(2)
	  k=j-1
          goto 5
        endif
        goto 10
20	close(2)
	end

	subroutine main_job(ma,f1,ch,jj,n1,n2)
	integer*2 ma(512,512)	
	integer*2 dummy(301*301)
	character f1*30,ch*1,c3*20
        write(c3,"(i3,':  (',i4,'*',i4,')   ')")jj,n1,n2
	ij=0
	do 1089 i=100,400
	do 1089 j=100,400
	ij=ij+1
1089	dummy(ij)=ma(i,j)
        call whitexblack(dummy,301,301,white,x)
	  write(*,*)'white',white,x
	black=white+20.*x
        call pgxgray(ma,512,512,1,512,1,512,white-5*x,black,2)
	call pglabel('R.A.','Decl.',c3//f1)
        x=512
	y=512
        call pgcurse(x,y,ch)
        call pgsci(0)
	call pglabel('R.A.','Decl.',c3//f1)
        call pgsci(1)
	end

	subroutine ch512(a,n1,n2,ibit,b,b0)
	integer a(1),b(1)
	if(ibit.eq.4) then
	 call swap4(a,n1*n2*4)
	 call r4to2(a,n1,n2,b)
        else
         call swap2(a,n1*n2*2)
 	 call shrink2(a,n1,n2,b,b0)
        endif

	end

	subroutine r4to2(a,n1,n2,b)
	real a(n1,n2),c(512*512),d(1000)
	integer*2 b(1)
	n=n1
	if(n2.lt.n1)n=n2
	m=n/512
	n=m*512
	k=0
	do 10 j=1,n,m
	do 10 i=1,n,m
	k=k+1
10	c(k)=a(i,j)
	k=0
	do 11 i=1,250000,250
	k=k+1
11	d(k)=c(i)
	do 12 i=1,999
	do 12 j=i+1,1000
	if(d(i).gt.d(j))then
	  x=d(i)
	  d(i)=d(j)
	  d(j)=x
	endif
12	continue
	x=d(500)
	if(x.lt.1000.)then
          do 20 i=1,512*512
20	  c(i)=c(i)+1000.
	endif
	if(x.gt.10000.)then
	  x=10000./x
	  do 30 i=1,512*512
30	  c(i)=c(i)*x
	endif
	do 40 i=1,512*512
	x=c(i)
	if(x.gt.32767.)x=32767.
40	b(i)=x
	end

	subroutine shrink2(a,n1,n2,b,b0)
	integer*2 a(n1,n2)
	integer*2 b(1)
	n=n1
	if(n2.lt.n1)n=n2
	m=n/512
	n=m*512
	k=0
	do 10 j=1,n,m
	do 10 i=1,n,m
	k=k+1
10	b(k)=(a(i,j)+b0)/2
	end

	subroutine inqh(f1,n1,n2,nhead,ibit,b0)
	character*(*) f1
	character*80 head(720)
	open(1,file=f1,status='old',access='direct',recl=57600)
	read(1,rec=1)head
	read(head(2)(22:),*)ibit
	read(head(4)(22:),*)n1	!NAXIS1
	read(head(5)(22:),*)n2	!NAXIS2
	ipos=indexpos(head,'OBJECT  ')
	write(*,'(1x,a)')head(ipos)(1:70)       	! object
	ipos=indexpos(head,'DATE-OBS')
	do 10 i=ipos,ipos+1				! da.ti.ex.ra.de.ha
10	write(*,'(1x,a)')head(i)(1:78)
	ipos=indexpos(head,'RA      ')
	write(*,'(1x,a)')head(ipos)(1:70)       	! object
	ipos=indexpos(head,'DEC     ')
	write(*,'(1x,a)')head(ipos)(1:70)       	! object
	b0=0
	ipos=indexpos(head,'BZERO   ')
	if(ipos.lt.720)read(head(ipos)(18:),*)b0
	nhead=indexpos(head,'END     ')
	close (1)
	end

	function indexpos(head,f1)
	character*80 head(720),f1*8
	byte bell
	do 10 indexpos=1,720
10	if(head(indexpos)(1:8).eq.f1)return
	end
