byte a(6144*6144*4+2880)
	real b(2048*2048)
	character*80 f1,f2,head(108)
	logical logi
        ii=iargc()
        if(ii.lt.2)then
	write(*,*)'     ********** shrink 6k-->2k **********2004.5*'
	write(*,*)
	write(*,*)'     Usage:  shrink62 inputfile outfile'
	write(*,*)
	stop
	endif
	call getarg(1,f1)
	k=index(f1,'.')
	if(k.eq.0)f1=f1(1:lnblnk(f1))//'.fit'
	inquire(file=f1,exist=logi)
	if(.not.logi)stop ' file not found !'
        call gethead(f1,head)
        ipos=indexpos(head,"NAXIS1  ")
        read(head(ipos)(27:),'(i4)')n1
        if(n1.ne.6144)stop "not 6k CCD pic"
	call readata(f1,a,b)
        ipos=indexpos(head,"NAXIS1  ")
        head(ipos)(27:30)='2048'
        read(head(ipos)(65:74),'(2i5)')ix1,ix2
        write(head(ipos)(65:74),'(2i5)')(ix1+2)/3,ix2/3
        ipos=indexpos(head,"NAXIS2  ")
        head(ipos)(27:30)='2048'
        read(head(ipos)(65:74),'(2i5)')ix1,ix2
        write(head(ipos)(65:74),'(2i5)')(ix1+2)/3,ix2/3
        n1=2048
	n2=2048
	call swap4(b,n1*n2*4)
	call getarg(2,f2)
        k=lnblnk(f2)+1
        f2(k:k)=char(0)
        k=indexpos(head,'END     ')
        if(nhead.lt.72)k=72
        if(nhead.gt.72)k=108
        call writefits(f2,head,80*k,1)
        call writefits(f2,b,n1*n2*4,0)
	end

        subroutine gethead(f1,head)
        character*80 f1,head(108)
        open(52,file=f1,status='old',access='direct',recl=8640)
        read(52,rec=1)head
        close (52)
        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

	subroutine readata(f1,a,b)
	byte c(2880),a(1),b(1)
	character*60 f1,ch*2880
	equivalence (c,ch)
	nn=2880
	open(3,file=f1,status='old',access='direct',recl=nn)	
	read(3,rec=1)ch
	k=index(ch,'BITPIX')+26
	read(ch(k:),'(i4)')ibit
        if(ibit.lt.0)ibit=-ibit
	k=index(ch,'NAXIS1')+26
	read(ch(k:),'(i4)')n1
	k=index(ch,'NAXIS2')+26
	read(ch(k:),'(i4)')n2
	n=1
55	k=index(ch,'END          ')
	if(k.eq.0)then
	n=n+1
	read(3,rec=n)ch
	goto 55
	endif
	ibit=ibit/8
	i=0
	do 60 k=n+1,n+(n1*n2*ibit-1)/nn+1
	read(3,rec=k,err=61)ch
	do 60 j=1,nn
	i=i+1
60	a(i)=c(j)
61	close (3)
        write(*,'(a,2i5)')f1(1:30),n1,n2
        if(n1.ne.6144)stop " not 6k*6k CCD pic"
	call swap4(a,n1*n2*4)
        call shrink9(a,n1,b)
	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