        character*40 f1,nf4(55),f5
	character*12 ac,dc,ch*1
	character*133 dis,err
	real*8 a8(8),adcoef(2,3)
	real sx(55),sy(55), pho(55),xw(55)
	character*80 head(72)	
	byte color(16)
	real sig(16)
	logical logi
	do 1 i=1,16
1	sig(i)=0.2

	sig(3)=1
	sig(4)=1
	sig(15)=1

        pi=4.*atan(1.)
        cx=pi/12.
        cy=pi/180.

	if(iargc().lt.3)then
	write(*,*)
	write(*,*)'       ******** DISplay star**********2000.7'
	write(*,*)
	write(*,*)
	write(*,*)' Usage: zmo4 list_fit_file all.cat number [dssfit]'
	write(*,*)
	stop
	endif

	call getarg(1,f1)
	inquire(file=f1,exist=logi)
	if(.not.logi)then
	  write(*,*)f1,'file not found !'
	  stop
	endif

	m4=0
	open(1,file=f1,status='old')
5	m4=m4+1
	read(1,'(a)',end=6)nf4(m4)
	f1=nf4(m4)
	k=index(f1,'.')
	if(k.eq.0)nf4(m4)=f1(1:lnblnk(f1))//'.fit'
	
	inquire(file=nf4(m4),exist=logi)
	if(.not.logi)then
	  write(*,*)nf4(m4),'file not found !'
	  stop
 	endif
        if(m4.eq.1)then
          call gethead(nf4(1),head)               ! mother file
          call geta8(head,a8)
          call xytoad(a8,adcoef)
          x=a8(7)
          y=a8(8)
          sx(1)=0
          sy(1)=0
	  xx=x/cx
	  yy=y/cy
	  call toms(xx,ac,1)
	  call toms(yy,dc,0)
	  write(*,*)' Center  ',ac,dc,'(2000.0)'
          ipos=indexpos(head,'VOLT3   ')
	  read(head(ipos)(25:),*)pho(m4)
        else 
          call gethead(nf4(m4),head)            
          ipos=indexpos(head,'A87     ')
          read(head(ipos)(20:),*)alpha
          read(head(ipos+1)(20:),*)delta
          ipos=indexpos(head,'VOLT3   ')
	  read(head(ipos)(25:),*)pho(m4)
          call standc(x,y,alpha,delta,xi,xn)
          sx(m4)=adcoef(1,1)*xi+adcoef(1,2)*xn+adcoef(1,3)-1024.5
          sy(m4)=adcoef(2,1)*xi+adcoef(2,2)*xn+adcoef(2,3)-1024.5
        endif
	  goto 5
6	  m4=m4-1
	write(*,*)'                                   shift     seeing'
        do 7 i=1,m4
7	write(*,8)i,nf4(i)(1:25),sx(i),sy(i),pho(i)
8	format(i2,':  ',a,2f6.2,f9.2)
	if(m4.gt.25)m4=25

        if5=0
        if(iargc().eq.4)then
          call getarg(4,f5)
          inquire(file=f5,exist=logi)
          if(.not.logi)then
            write(*,*)f5,'file not found !'
          else
            call dsshead(f5)
	    write(*,*)f5
          endif
        endif


	call pgbegin(0,'/xw',1,1)
	call pgpap(7.05,1.)
	call pgsch(0.8)
	call pgsci(0)
	call pgenv(0.,1.,0.,1.,0,0)
	
	call getarg(2,f1)
	open(1,file=f1,status='old')
	open(9,file='mo4.tmp',status='unknown')
	call getarg(3,ac)
	read(ac(1:),*)ip
	ip=ip-1
	read(1,'(a)')dis
	do 91 i=1,m4
	j=36+i*6
91	color(i)=ichar(dis(j:j))
	  mm=133-(16-m4)*6
	write(9,'(a)')dis(1:mm)
	do 9 i=1,ip
	read(1,'(a)',end=79)dis
	read(1,'(a)')err
	if(ichar(dis(1:1)).eq.13)dis(1:1)=' '
	if(dis(1:1).eq.'q')dis(1:1)=' '
	write(9,'(a)')dis(1:mm)
9	write(9,'(a)')err(1:mm)
10      call pgpage1
	read(1,'(a)',end=79)dis
	read(1,'(a)')err
	ip=ip+1
c	if(dis(1:1).eq.'e')goto 100
	if(dis(1:1).ne.'z')goto 100
	write(*,*)ip,':  ',dis(1:43)
	j=3
	if(dis(1:1).ne.' ')j=1

	call pgsci(j)
	
	call dist(dis,color,m4)

	call itohd(dis(2:),alpha,delta,xx)
        alp=alpha*cx
	del=delta*cy
          call standc(x,y,alp,del,xi,xn)
          alp=adcoef(1,1)*xi+adcoef(1,2)*xn+adcoef(1,3)
          del=adcoef(2,1)*xi+adcoef(2,2)*xn+adcoef(2,3)
	  alp=2049.-alp
	  del=2049.-del
        j1=30
        j2=600
	do 13 i=1,m4
        i1=alp+sx(i)+0.5
        i2=del+sy(i)+0.5
        pho(i)=disp4(nf4(i),i1,i2,j1,j2,xw(i),sig(i))
        j1=j1+120
	if(j1>530)then
	  j1=30
	  j2=j2-140
	endif
13	continue
        if(if5.ne.0)call dsstar(f5,alpha,delta,j1,j2)
c103	do 102 i=1,m4
c	j=32+i*6
c        write(*,"(a,' ',a,': ',$)")dis(j:j+5),color(i)
c	read(*,'(a)')ch
c	 if(i.eq.1.and.ch.eq.'q')goto 100
c	 if(i.eq.1.and.ch.ne.' ')goto 109
c	if(ch.eq.'`')goto 103
c	err(j+1:j+1)=ch
c102	continue
        ch='X'	
101	call pgcurse(xy,yx,ch)
109	ich=ichar(ch)
	if(ch.eq.'A')ich=128               ! forward
	if(ch.eq.'D')ich=130               ! exit
	if(ch.eq.'X')ich=132               ! nothing
	if(ich.eq.132)goto 101
	if(ich.lt.128.and.ich.ge.32)dis(1:1)=ch   ! mark
100	write(9,'(a)')dis(1:mm)
	write(9,'(a)')err(1:mm)
	if(ich.eq.130)then
72        read(1,'(a)',end=79)dis
	  read(1,'(a)')err
          write(9,'(a)')dis(1:mm)
	  write(9,'(a)')err(1:mm)
          goto 72
	endif
 	goto 10
79      call pgend
        close (9)
	write(2,*)ip
        call system("cp mo4.tmp "//f1)
	end	


        subroutine dsshead(f1)
        character*(*) f1
        real*8 pse,xz,yz,px,py,a_c,d_c,ax(13),ay(13),cx,cy
        common /head/pse,xz,yz,a_c,d_c,px,py,ax,ay,cx,cy
        common /dss/nn1,nn2,a1,a2,d1,d2,npix1,npix2
        call getdsshead(f1)
        x1=1+npix1
        y1=1+npix2
        call amdpos(x1,y1,a1,d1)
        x1=nn1+npix1
        y1=nn2+npix2
        call amdpos(x1,y1,a2,d2)
c by using a1,a2; d1,d2 calculate new star
        if(a1.lt.a2)a1=a1+24.
        end

        subroutine getdsshead(f1)
        character*(*) f1
        character*80 head(108)
        real*8 pse,xz,yz,px,py,a_c,d_c,ax(13),ay(13),cx,cy
	logical logi
        common /head/pse,xz,yz,a_c,d_c,px,py,ax,ay,cx,cy
        common /dss/nn1,nn2,a1,a2,d1,d2,npix1,npix2
        cy=atan(1d0)/45d0
        cx=cy*15.
        if(index(f1,'.').eq.0)f1=f1(1:lnblnk(f1))//'.fits'
        inquire(file=f1,exist=logi)
        if(.not.logi)stop "File not found !"
        open(41,file=f1,status='old',access='direct',recl=8640)
        read(41,rec=1)head
        close (41)
        call ival(head,'NAXIS1  =',nn1)
        call ival(head,'NAXIS2  =',nn2)
        call ival(head,'CNPIX1  =',npix1)
        call ival(head,'CNPIX2  =',npix2)
        call fval(head,'PLTSCALE=',pse)
        call fval(head,'XPIXELSZ=',xz)
        call fval(head,'YPIXELSZ=',yz)
        call cval(head,'PLTRAH  =')
        call fval(head,'PPO3    =',px)
        call fval(head,'PPO6    =',py)
        call aval(head,'AMDX1   =',ax)
        call aval(head,'AMDY1   =',ay)
        end

        subroutine ival(head,word,k)
        character*80 head(110)
        character*9 word
        do 10 i=1,110
        if(head(i)(1:9).eq.word)goto 20
10      continue
        stop "not DSS fits file !"
20      read(head(i)(21:),*)k
        end

        subroutine rval(head,word,tmp)
        character*80 head(110)
        character*9 word
        do 10 i=1,110
        if(head(i)(1:9).eq.word)goto 20
10      continue
        stop "not DSS fits file !"
20      read(head(i)(11:),*)tmp
        end

        subroutine fval(head,word,tmp)
        character*80 head(110)
        character*9 word
        real*8 tmp
        do 10 i=1,110
        if(head(i)(1:9).eq.word)goto 20
10      continue
        stop "not DSS fits file !"
20      read(head(i)(11:),*)tmp
        end

        subroutine cval(head,word)
        character*80 head(110)
        character*9 word
        real*8 a,d
        real*8 pse,xz,yz,px,py,a_c,d_c,ax(13),ay(13),cx,cy
        common /head/pse,xz,yz,a_c,d_c,px,py,ax,ay,cx,cy
        do 10 i=1,110
        if(head(i)(1:9).eq.word)goto 20
10      continue
        stop "not DSS fits file !"
20      read(head(i)(22:),*)j
        read(head(i+1)(22:),*)k
        read(head(i+2)(11:),*)x    ! 95,3  modify for north plate
        a=j+k/60.+x/3600.
        read(head(i+4)(22:),*)j
        read(head(i+5)(22:),*)k
        read(head(i+6)(11:),*)x
        d=j+k/60.+x/3600.
        if(head(i+3)(12:12).eq.'-')d=-d
        a_c=a*cx
        d_c=d*cy
        end

        subroutine aval(head,word,a)
        character*80 head(110)
        character*9 word
        real*8 a(1)
        do 10 i=1,110
        if(head(i)(1:9).eq.word)goto 20
10      continue
        stop "not DSS fits file !"
20      do 30 k=1,13
        read(head(i)(11:),*)a(k)
30      i=i+1
        end

        subroutine amdpos(x,y,ra,dec)
        real*8 ox,oy,ox2,oy2,ox3,oy3,xi,yi,n,d,r
        real*8 pse,xz,yz,px,py,a_c,d_c,ax(13),ay(13),cx,cy
        common /head/pse,xz,yz,a_c,d_c,px,py,ax,ay,cx,cy
        ox = (px - x*xz)/1000.0
        oy = (y*yz - py)/1000.0
        ox2 = ox*ox
        oy2 = oy*oy
        ox3 = ox*ox2
        oy3 = oy*oy2
        xi = ax(1)*ox + ax(2)*oy + ax(3) + ax(4)*ox2 + ax(5)*ox*oy +
     *       ax(6)*oy2 + ax(7)*(ox2+oy2) + ax(8)*ox3 + ax(9)*ox2*oy +
     *       ax(10)*ox*oy2 + ax(11)*oy3  + ax(12)*ox*(ox2+oy2) +
     *       ax(13)*ox*(ox2+oy2)*(ox2*oy2)
        yi = ay(1)*oy + ay(2)*ox + ay(3) + ay(4)*oy2 + ay(5)*oy*ox +
     *       ay(6)*ox2 + ay(7)*(oy2+ox2) + ay(8)*oy3 + ay(9)*oy2*ox +
     *       ay(10)*oy*ox2 + ay(11)*ox3  + ay(12)*oy*(oy2+ox2) +
     *       ay(13)*oy*(oy2+ox2)*(oy2*ox2)
        xi=xi*cy/3600.
        yi=yi*cy/3600.
        n=xi/dcos(d_c)
        d=1-yi*dtan(d_c)
        r=datan2(n,d)+a_c
        n=dcos(r-a_c)
        d=d/(yi+dtan(d_c))
        dec=datan(n/d)/cy
        ra=r/cx
        if(ra.lt.0.)ra=ra+24.
        end

cccccccc
	subroutine dist(dis,color,m4)
	character*133 dis
	character*1 color(16)
	y=1.05
	k=0
	do 10 j=1,5
	x=0
	do 20 i=1,5
	k=k+1
	if(k.gt.m4)goto 30
	l=k*6+32
	call pgtext(x,y,dis(l:l+5)//'  '//color(k))
20	x=x+0.22
10	y=y-0.26
30	call pgtext(x,y,'dss')
	return
	end

	function disp4(f1,i1,i2,ix,iy,xwi,sig)
	character*40 f1
	integer*2 map(101*101),ma(101*101)
	real xmap(101*101)
	if(i1.lt.1.or.i1.gt.2048.or.i2.lt.1.or.i2.gt.2048)then
	  do i=1,101*101
	  map(i)=0
	  enddo
	  goto 204
	else      
  	  call readcc(f1,xmap,i1,i2)
	endif
	ip=0
        do 203 i=1,101*101
	if(xmap(i).le.0.)then
	  map(i)=32767
	else
   	  ip=ip+1
	  j=xmap(i)*sig
	  if(j.gt.32766)j=32766
	  ma(ip)=j
          map(i)=j
	endif
203	continue
	call whitexblack(ma,1,ip,white,sigma)
c        if(sigma.lt.5.)sigma=5.
	if(white.lt.400)white=white*0.9
	if(white.gt.0.)then
	  xw=white
	else
	  white=xw
	endif
c	disp4=photo(xmap,white*4.)
204     call ximage2(map,101,ix,iy,white*0.95,white+20.*sigma)
	end

	function photo(a,white)
	real a(101,101)
	xx=0
        do 206 j1=-5,+5
        do 206 j2=-5,+5
	k=j1*j1+j2*j2
	if(k.gt.25)goto 206
	x=a(51+j1,51+j2)-white
	if(x.gt.0)xx=xx+x
206	continue
	photo=25.-2.5*alog10(xx)
	end

cccccccccc
        subroutine dsstar(f1,xx,yy,ix,iy)
        character*40 f1
        integer*2 map(101*101),ma(101*101)
        common /dss/nn1,nn2,a1,a2,d1,d2,npix1,npix2
        xc=xx
        yc=yy
        ip=0
10      x=(nn1-1)/(a2-a1)*(xc-a1)+1.
        y=(nn2-1)/(d2-d1)*(yc-d1)+1.
        if(x.lt.1.or.y.lt.1.or.x.gt.nn1.or.y.gt.nn2)then
          do 20 i=1,101*101
20        map(i)=0
          goto 209
        endif
        x1=x+npix1
        y1=y+npix2
        call amdpos(x1,y1,x2,y2)
        x=(x-1)/(x2-a1)*(xc-a1)+1.
        y=(y-1)/(y2-d1)*(yc-d1)+1.
cccccccccccc
        x1=x+npix1
        y1=y+npix2
        call amdpos(x1,y1,x2,y2)
        x1=xx-x2
        y1=yy-y2
c          write(*,'(3f10.6)')xx,x2,x1
c          write(*,'(3f10.6)')yy,y2,y1
        if(abs(x1).gt.0.0001.or.abs(y1).gt.0.0015)then
           xc=xc+x1
           yc=yc+y1
           ip=ip+1
           if(ip.lt.10)goto 10
           do 30 i=1,101*101
30         map(i)=0
           goto 209
        endif
cccccccccccc
        i1=x+0.5
        i2=y+0.5
        call readd(f1,map,i1,i2,nn1,nn2)
        ip=0
        do 203 i=1,101*101
	if(map(i).lt.10.or.map(i).gt.30000)write(*,*)map(i)
        if(map(i).eq.32767)goto 203
        ip=ip+1
        ma(ip)=map(i)
203     continue
        call whitexblack(ma,1,ip,white,sigma)
c	write(*,*)ip,white,sigma
         if(sigma.lt.30.)sigma=30.
	 if(sigma.gt.50.)sigma=50.
209     call ximage2(map,101,ix,iy,white*.9,white+40.*sigma)
        end

        subroutine ximage2(map,n,iix,iiy,black,white)
        integer*2 map(n,n)
        character dummy,c*16
        real rbuf(101*101+2)
        n16=84
        d=n16/(black-white)
        rbuf(1)=iix
        do 40 j=1,n
        rbuf(2)=iiy-j
        i6=2
        do 30 i=1,n
        k=nint(d*(map(i,j)-white))
        if(k.lt.1)k=1
        if(k.gt.n16)k=n16
        i6=i6+1
30      rbuf(i6)=k+15
        call xwdriv(26,rbuf,i6,dummy)
        call pgebuf
40      continue
	end

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

        subroutine geta8(head,a8)
        real*8 a8(8)
        character*80 head(72)
        ipos=indexpos(head,'A81     ')-1
        do 10 i=1,8
10      read(head(i+ipos)(12:),*)a8(i)
        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
