	character*30 f0,f1,ch*1
	integer*2 b(512*512)
 	integer*2 a(2048*3*2048*3*2)		! -32 change to 16 when cal.
	character*80 head(72)
	real*8 a8(8)
	common /xinglong/pi,cx,cy,sphi,cphi,s0,iy,im,id,ut
	pi=4.*atan(1.0)
	cx=pi/12.
	cy=pi/180.
  	phi=(40.+23/60.+36/3600.)*pi/180.	! XL latitude
  	sphi=sin(phi)
	cphi=cos(phi)

        write(*,*)
	write(*,*)' Usage: tv_look [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 >1.1")
 	call pgbegin(0,'/xw',1,1 )
	call pgpap(5.5,1.015)
	call pgsci(0)
        call pgenv(1.,2048.,2048.,1.,0,0)
	call pgsci(1)
5	if(k.lt.1)k=1
        open(2,file='1.1',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

        if(inqh(f1,n1,n2,head,ibit).eq.0)stop 'DATA not found'
	call getpar(head)	
c read data
11	sky=0.
	ipos=indexpos(head,'VOLT2   ')
	if(ipos.ne.73) read(head(ipos)(20:),*,err=99)sky
12	call readata(a,b,f1,ibit,sky,n1)
	iturn=0
        if((iy-1900)*10+im.ge.945.or.iy.lt.1990)iturn=1
c turn image 
	m1=512
	m2=512
	ipos=indexpos(head,'INSTRUME')
	if(ipos.ne.73)then
          do i=12,20
	  if(head(ipos)(i:i).eq.'3')iturn=0
	  if(head(ipos)(i:i).eq.'4')iturn=4
	  enddo
	endif
	if(iturn.eq.0)call turnx2(b,m1,m2,-180)
	if(iturn.eq.1)call turnx2(b,m1,m2,-360)
	if(iturn.eq.4)call turnx2(b,m1,m2,180)
c main_job
	call main_job(b,f1,ch,j,n1)
        if(ch.eq.'D')stop
        if(ch.eq.'X')then
          close(2)
	  k=j-1
          goto 5
        endif
        goto 10
99      sky=20001.
	goto 12
20	close(2)
	end

	subroutine main_job(ma,f1,ch,jj,n1)
	integer*2 ma(512,512)	
	integer*2 dummy(301*301)
	character f1*30,ch*1,c3*18
        write(c3,"(i3,':  (',i4,')   ')")jj,n1
	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)
	black=white+20.*x
        call pgxgray(ma,512,512,1,512,1,512,white-5*x,black,2)
	call pglabel('R.A. south','Decl. east',c3//f1)
        x=1024
	y=1024

        call pgcurse(x,y,ch)
        call pgsci(0)
	call pglabel('R.A. south','Decl. east',c3//f1)
        call pgsci(1)
	end

	subroutine getpar(head)
c get s0 iy im id ut
	character*80 head(72)
	real*8 d1,d
	common /xinglong/pi,cx,cy,sphi,cphi,s0,iy,im,id,ut
	ipos=indexpos(head,'DATE-OBS')
	read(head(ipos)(22:),'(i2,1x,i2,1x,i2)')id,im,iy	! read obs date
	iy=iy+1900
	if(iy.lt.1950)iy=iy+100
	ipos=indexpos(head,'TIME    ')
	read(head(ipos)(20:),'(i2,1x,i2,1x,f4.1)')i,j,x
	ipos=indexpos(head,'EXPOSURE')
	read(head(ipos)(20:),*)k				! exp time
	ut=i+j/60.+x/3600.+k/7200.			! center UT time, in h
        call fjd(d1,1992,12,31)			! 1992,12,31
        d2=(6+38/60.+40.1954/3600.)/24.         ! 6 38 40.1954
        x1=7+50/60.+18.344/3600.                ! 7:50:18.344 lamda of XL
        call fjd(d,iy,im,id)
        d=(d-d1)*1.0027379093d0+d2
        d=dmod(d,1d0)
        if(d.lt.0d0)d=d+1d0
        s0=d*24d0
        s0=s0+x1+ut*1.002738
	end

        subroutine fjd(d,iy,im,id)
        real*8 d
        i=(im+9)*0.09
        i=(i+iy-1900)*1.75+0.01
        j=30.56*im
        j=(iy-1950)*367+id+j-i
        d=2433338.5d0+j
        end

	subroutine readata(a,b,f1,ibit,sky,jj)
	integer c(720),a(1),b(1)
	character*30 f1,ch*2880
	equivalence (c,ch)
	nn=720						
	open(1,file=f1,status='old',access='direct',recl=nn*4)
	read(1,rec=1)ch
	n1=jj
	n2=jj
        id=jj/2048
        id=id*id*120
	n=1
55	k=index(ch,'END     ')
	if(k.eq.0)then
	  n=n+1
	  read(1,rec=n)ch
	  goto 55
	endif
	i=0
	if(ibit.lt.0)ibit=-ibit
	k1=n+1
	k2=n+(n1*n2*ibit/32-1)/nn
	do 60 k=k1,k2
	read(1,rec=k)ch
	do 60 j=1,nn
	i=i+1
60	a(i)=c(j)
	close (1)
	if(ibit.eq.32)then
	  call swap4(a,n1*n2*4)
           if(n1.eq.6144)then
             call shrink9(a,n1,a)
             n1=2048
             n2=2048
           endif
           if(n1.eq.4000)then
             call shrink8(a,n1,a)
             n1=4096
             n2=4096
           endif
	  if(sky.gt.20000.)then
	    write(*,*)'warnning:  background too high!'
	    call shdata(a,n1*n2)
	  endif
	  call shrink4(a,n1,n2,a)
	else
	  call swap2(a,n1*n2*2)
	endif
 	call shrink2(a,n1,n2,b)		! 2048*2048-->512*512
	end

	subroutine shdata(a,n)
	real a(n)
	do 10 i=1,n
10	a(i)=a(i)*0.1
	end

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

	subroutine shrink4(a,n1,n2,b)
	real a(n1*n2)
	integer*2 b(n1*n2)
	do 10 i=1,n1*n2
	x=a(i)
        if(x.gt.32767.)x=32767.
        if(x.lt.0.)x=0.
10	b(i)=x
	end

       subroutine shrink8(a,n,b)
       real a(n,n),b(4096,4096)
	real c(4096,4096)
	do 10 j=1,n
	do 10 i=1,n
10	c(i,j)=a(i,j)
	do 20 j=1,n
	do 20 i=1,n
20	b(i,j)=c(i,j)
	end

       subroutine shrink9(a,n,b)
       real a(n,n),b(2048,2048)
        do 10 j=1,2048
        do 10 i=1,2048
        x=0.
        do 20 jj=-2,0
        k=j*3+jj
        do 20 ii=-2,0
20      x=x+a(i*3+ii,k)
10      b(i,j)=x/9.
        end

	function inqh(f1,n1,n2,head,ibit)
	character*(*) f1
	character*80 head(72)
	logical inqh
	k=index(f1,'.')
	if(k.eq.0)f1=f1(1:lnblnk(f1))//'.fit'
	inquire(file=f1,exist=inqh)
	if(.not.inqh)return
	open(1,file=f1,status='old',access='direct',recl=5760)
	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')
        head(ipos)(63:72)='(dd/mm/yy)' 
	do 10 i=ipos,ipos+5				! da.ti.ex.ra.de.ha
10	write(*,'(1x,a)')head(i)(1:78)
        ipos=indexpos(head,'TELESCOP')
        if(ipos.ne.73)head(ipos)(12:28)='BAO 60-90 SCHIMDT'
        ipos=indexpos(head,'BZERO   ')
        if(ipos.ne.73)head(ipos)(1:1)='P'
        ipos=indexpos(head,'BSCALE  ')
        if(ipos.ne.73)head(ipos)(1:1)='P'
        ipos=indexpos(head,'TIME    ') 
        if(ipos.ne.73)head(ipos)(42:57)='OF START OF OBS.' 
        ipos=indexpos(head,'HA      ')
        if(ipos.ne.73)head(ipos)(45:61)='OF MIDDLE OF OBS.' 
	close (1)
	end

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