c 4k*4k ---> 2k*2k
c scale as 2k
c == extract 2048*17/13 square ccd, shrink to 2k.

	character*80 f2,f3,head2(72)
	real a(2048,2048),b(4096,4096)
	integer*2 c(2048,2048)

        iarg=iargc()
	if(iarg.lt.2)then
	  write(*,*)
	  write(*,*)'         ******** 4k*4k ccd -->2k*2k ccd ********'
	  write(*,*)'         scale as 2k, marked at 2nd line of fits_head'
          write(*,*)
          write(*,*)'           b4kto2k input(4k) output(2k)'
          write(*,*)
	  write(*,*)'                      jiang      2008,12'
          write(*,*)
          write(*,*)
	  stop
	endif

	call getarg(1,f2)
	open(1,file=f2,status='old',iostat=i,access='direct',recl=5760)
	if(i.ne.0)stop 'input file not found!'
	read(1,rec=1)head2
	ipos=indexpos(head2,'A81     ')
	if(ipos.lt.72)stop 'use s4kto2k please !'
	ipos=indexpos(head2,'BITPIX  ')
	read(head2(ipos)(16:),*)ibit
	b0=0.
	ipos=indexpos(head2,'BZERO   ')
	if(ipos.lt.72)read(head2(ipos)(16:),*)b0
	ipos=indexpos(head2,'NAXIS1  ')
	read(head2(ipos)(16:),*)n1
	if(n1.ne.4096)stop 'inp_file not a 4k*4k file'
	close(1)
        call readfits(f2,b,n1,n1)
	if(ibit.eq.16)call ch4(b,b,n1,b0)

        s=17./13.6
        s2=n1/2+0.5

	do 10 i=1,2048
	if(i/100*100.eq.i)call dispdot()
        x=s2+(i-1024.5)*s
        ix0=x
	ix1=ix0+1
        wx=x-ix0
	zx=1.-wx
	do 10 j=1,2048
        y=s2+(j-1024.5)*s
        iy0=y
        iy1=iy0+1
        wy=y-iy0
        zy=1.-wy
        x1=zx*zy
        x2=wx*zy
        x3=zx*wy
        x4=wx*wy
        a(i,j)=b(ix0,iy0)*x1+b(ix1,iy0)*x2+b(ix0,iy1)*x3+b(ix1,iy1)*x4
10	continue	
	n1=2048
	call getarg(2,f3)
        write(head2(2)(65:74),"('from 4k*4k')")
        write(head2(4)(27:30),"('2048')")
        write(head2(5)(27:30),"('2048')")
	if(ibit.eq.16)then
	  call sh4(a,c,n1,b0)
	  call swap2(c,n1*n1*2)
          k=n1*n1*2+5760
          open(1,file=f3,status='unknown',access='direct',recl=k)
	  write(1,rec=1)head2,c
	else
          call swap4(a,n1*n1*4)
          k=n1*n1*4+5760
          open(1,file=f3,status='unknown',access='direct',recl=k)
	  write(1,rec=1)head2,a
	endif
	write(*,*)'ok !'	
	close(1)
	end

	subroutine ch4(a,b,n,b0)
	integer*2 a(1)
	real      b(1)
	do 10 i=n*n,1,-1
10	b(i)=a(i)+b0
	end

	subroutine sh4(a,b,n,b0)
	real a(1)
	integer*2 b(1)
	do 10 i=1,n*n
10	b(i)=a(i)-b0
	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
