c
	parameter (n1=8640)
	parameter (n2=8200)
	character*69 f1,aa
	integer a(190000)
	real b(190000,8)
	character*80 head(72)
	logical logi
        real a1(n1*n2),b1(n1*n2)
	
	k=iargc()
	if(k.lt.1)then
	  write(*,*)
	  write(*,*)'***** Usage: u_4to1 file (2012,1)********'
	  write(*,*)
	  write(*,*)'   for 8640*8200 ccd, 190,000 stars'
	  write(*,*)
	  stop
	endif
	call getarg(1,f1)
        k=index(f1,'.')
	if(k.ne.0)f1=f1(1:k-1)//'  '

	k=lnblnk(f1)
ccccccccc for als
 
        call system('als4 '//f1(1:lnblnk(f1)))
        call j_1(f1,a,b,n)           ! 4 ?.als-> all.als  coo_star j_xy4ad
        call lst_4to1(f1)            ! 4 lst --> all.lst  
                                     ! according above als_mag, put in
c for fits
	aa=f1(1:k)//'.fit'//char(0)
	call gethead(aa,head)
	call fits_4to1(f1,head,a1,b1,n1,n2)
	write(*,*)'ok'

	end

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

	subroutine fits_4to1(f1,head,a,b,n1,n2)
	character*69 f1,f2
	character*80 head(72)
        real a(n1,n2),b(n1,n2)
        logical logi
        integer mx(4),my(4)
        data mx/0,4320,0,4320/
        data my/0,0,4100,4100/

	k=lnblnk(f1)
	do 11 m=1,4
	f2=f1(1:k)//char(m+48)//'.fits'//char(0)
        inquire(file=f2,exist=logi)
	if(.not.logi)return
        m1=n1
	m2=n2
        call readfits(f2,b,m1,m2)    ! n1,n2 as para, call c routine, must var.
	do 10 i=mx(m)+1,mx(m)+n1/2
	do 10 j=my(m)+1,my(m)+n2/2
10	a(i,j)=b(i,j)
11      write(*,*)f2
	f2=f1(1:k)//'.fits'//char(0)
	write(*,*)f2
	call swap4(a,n1*n2*4)

	call writefits(f2,head,80*72,1)
	call writefits(f2,a,n1*n2*4,0)
	end

	subroutine gethead(f1,head)
	character*80 f1,head(72)
	open(52,file=f1,status='old',access='direct',recl=5760)
	read(52,rec=1)head
	close (52)
	end

	subroutine lst_4to1(f1)  ! deal with *.lst, psf star
	character*69 f1
	call system('cat '//f1(1:lnblnk(f1))//'?.lst >1.tmp')
	call system('sort -n --key=4 1.tmp>'//f1(1:lnblnk(f1))//'.lst')
	end

	subroutine sortn(k,di,d1,d2,d3,d4,d5,d6)
	real d1(270),d2(270),d3(270),d4(270),d5(270),d6(270)
	integer di(270)
c	  write(*,*)k
	do 10 i=1,k-1
	do 10 j=i+1,k
	if(d3(i).gt.d3(j))then
	  n=di(i)
	  di(i)=di(j)
	  di(j)=n
	  x=d1(i)
	  d1(i)=d1(j)
	  d1(j)=x
	  x=d2(i)
	  d2(i)=d2(j)
	  d2(j)=x
	  x=d3(i)
	  d3(i)=d3(j)
	  d3(j)=x
	  x=d4(i)
	  d4(i)=d4(j)
	  d4(j)=x
	  x=d5(i)
	  d5(i)=d5(j)
	  d5(j)=x
	  x=d6(i)
	  d6(i)=d6(j)
	  d6(j)=x
	endif
10	continue
	end


	subroutine j_1(f1,a,b,n)

	character*69 f1,f2,c1,c2
	real b(50000,8),xx(4)
	integer a(50000)

        integer mx(4),my(4)
        data  mx/0,4320,0,4320/
        data  my/0,0,4100,4100/
        k=lnblnk(f1);
        open(1,file=f1(1:k)//'.als4',status='old')
        do i=1,8
        read(1,'(a)')c1
        enddo
        read(1,*)xx(1),xx(2),xx(4),xx(3)
	close(1)
        write(*,*)' read adjust 4_gate bias x1,x2,x3,x4 from a*.als4'
        write(*,*)(xx(i),i=1,4)
	i=0
        do 5 iz=1,4
          xx1=mx(iz)
          xx2=xx1+mx(4)
          yy1=my(iz)
          yy2=yy1+my(4)
	k=lnblnk(f1)
	f2=f1(1:k)//char(48+iz)//'.als'
	open(1,file=f2,status='old')
	read(1,'(a)')c1
	read(1,'(a)')c2
	read(1,'(a)')j
10	i=i+1
	read(1,*,end=100)a(i),(b(i,j),j=1,8)
         x=b(i,1)
         y=b(i,2)
         b(i,3)=b(i,3)+xx(iz)
        if(x.le.xx1.or.x.gt.xx2.or.y.le.yy1.or.y.gt.yy2)i=i-1
	goto 10
100	i=i-1
	close(1)
5	write(*,*)f2,i
        n=i

	call sortm(a,b,n)

	f2=f1(1:k)//'.als'
	open(3,file=f2,status='unknown')
        write(3,'(a)')c1
        write(3,'(a)')c2
        write(3,'(a)')
	do 70 i=1,n
        if(b(i,5).lt.9999.99 .and. x5.gt.-999.99)then
        write(3,2)a(i),(b(i,j),j=1,8)
2       FORMAT (I6, 3F9.3, F9.4, F9.3, F9.0, 2F9.3)
        ELSE
        write(3,3)a(i),(b(i,j),j=1,8)
3       FORMAT (I6, 3F9.3, F9.4, F9.2, F9.0, 2F9.3)
        endif
70	continue
        close(3)
	end

      subroutine sortm(a,b,n)
      integer a(1)
      real b(50000,8),u(8)
      int=2
   10 int=2*int
      if(int.lt.n)goto 10
      int=min0(n,(3*int)/4-1)
   20 int=int/2
      ifin=n-int
      do 70 ii=1,ifin
      i=ii
      j=i+int
      if(a(i).le.a(j))goto 70
      it=a(j)
	do k=1,8
	u(k)=b(j,k)
	enddo
   40 a(j)=a(i)
        do k=1,8
	b(j,k)=b(i,k)
	enddo	
      j=i
      i=i-int
      if(i.le.0)goto 60
      if(a(i).gt.it)goto 40
   60 a(j)=it
	do k=1,8
	b(j,k)=u(k)
	enddo
   70 continue
      if(int.gt.1)goto 20
      return
      end

