	real a(2048*2048)
	integer*2 b(512*512)
        character*80 head(72)
	character*60 f1
	logical logi
        ia=iargc()
	if(ia.lt.2)write(*,*)
	if(ia.lt.2)write(*,*)' ** display & modify armenia Fits ** 2001.10'
	if(ia.lt.2)write(*,*)
	if(ia.eq.0)write(*,*)' Usage: disfa *.fit !'
	if(ia.lt.2)write(*,*)
	if(ia.ne.0)then
	  call getarg(1,f1)
	  goto 10
	endif
20	write(*,'(a,$)')'Input *.fits_names: '
	read(*,'(a)')f1
10	k=index(f1,'.')
	if(k.eq.0)f1=f1(1:lnblnk(f1))//'.fits'
	inquire(file=f1,exist=logi)
	if(.not.logi)then
	  write(*,*)' file not found !'
	  goto 20
	endif
	call readata(f1,head,a,b,ia)
	if(ia.gt.1)call wrfit('p'//f1,head,a)
	if(ia.le.1)call dis(f1,b,512,512)
	end

	subroutine wrfit(f1,head,a)
	character*60 f1
	character*80 b(72)
	byte head(80,72),c(80,72)
	real a(2048*2048)
	equivalence (b,c)

	do 4 j=1,72
	do 5 i=1,64
5	c(i,j)=head(i,j)
	do 6 i=65,80
6	c(i,j)=32
4	continue

	write(b(2)(1:64),'(a)')
     *"BITPIX  =                  -32 / DATA PRECISION                 "
	write(b(4)(1:64),'(a)')
     *"NAXIS1  =                 2048 / NUMBER OF COLUMNS              "
	write(b(5)(1:64),'(a)')
     *"NAXIS2  =                 2048 / NUMBER OF ROWS                 "
	write(b(6)(1:64),'(a)')
     *"BLOCKED =                    T / CHECK FOR POSSIBLE BLOCKING    "
	write(b(7)(1:64),'(a)')
     *"CRVAL1  =                    0 / COLUMN ORIGIN                  "
	write(b(8)(1:64),'(a)')
     *"CRVAL2  =                    0 / ROW ORIGIN                     "
	write(b(9)(1:64),'(a)')
     *"CDELT1  =             1.000000 / COLUMN BINNING                 "
	write(b(10)(1:64),'(a)')
     *"CDELT2  =             1.000000 / ROW BINNING                    "
	write(b(11)(1:64),'(a)')
     *"IMNAME  = '                  ' / OBSERVATION SEQUENCE NAME      "
        call putch(head,12,c,11) 
	write(b(12)(1:64),'(a)')
     *"DATE-OBS= '                  ' / DATE OF START OF OBS (dd/mm/yy)"
        call putdate(head,18,c,12) 
	write(b(13)(1:64),'(a)')
     *"TIME    = '                  ' / LOCAL TIME OF START OF OBS.    "
        if(head(20,19).eq.32)then
          head(20,19)=46
          head(21,19)=48
	endif
        call putch(head,19,c,13) 
	write(b(14)(1:64),'(a)')
     *"EXPOSURE=                      / EXPOSURE TIME (SEC)            "
	call putri(head,20,c,14)
	write(b(15)(1:64),'(a)')
     *"RA      = '                  ' / RIGHT ASCENSION                " 
	call put0(head,23)
        call putch(head,23,c,15) 
	write(b(16)(1:64),'(a)')
     *"DEC     = '                  ' / DECLINATION                    "
	call put0(head,24)
        call putch(head,24,c,16) 
	write(b(17)(1:64),'(a)')
     *"HA      = '        00:00:00.0' / HOUR ANGLE OF MIDDLE OF OBS.   "
        call putline(head,25,c,18) 
	write(b(19)(1:64),'(a)')
     *"VOLT1   =               0.0000 / TEMPERATURE                    "
	write(b(20)(1:64),'(a)')
     *"VOLT2   =               0.0000 /                                "
	write(b(21)(1:64),'(a)')
     *"VOLT3   =               0.0000 /                                "
	write(b(22)(1:64),'(a)')
     *"VOLT4   =               0.0000 / 5 VOLT SUPPLY                  "
	write(b(23)(1:64),'(a)')
     *"VOLT5   =               0.0000 / DRAIN VOLTAGE                  "
	write(b(24)(1:64),'(a)')
     *"VOLT6   =               0.0000 / SUBSTRATE VOLTAGE              "
	write(b(25)(1:64),'(a)')
     *"VOLT7   =               0.0336 / UNUSED                         "
	call putline(head,11,c,26)
	call putline(head,46,c,27)
	call putline(head,47,c,28)
	call putline(head,13,c,29)
	call putline(head,14,c,30)
	call putline(head,16,c,31)
	call putline(head,15,c,32)
	write(b(33)(1:64),'(a)')
     *"PZERO   =             0.000000 / ZERO POINT BIAS                "
	write(b(34)(1:64),'(a)')
     *"PSCALE  =             1.000000 / IMAGE SCALE FACTOR             "
	call putline(head,39,c,35)
	write(b(36)(1:64),'(a)')
     *"CRPIX1  =                    1 / PIXEL CORRESPONDING TO CRVAL1  "
	write(b(37)(1:64),'(a)')
     *"CRPIX2  =                    1 / PIXEL CORRESPONDING TO CRVAL2  "
	call putline(head,17,c,38)
	call putline(head,30,c,39)
	call putline(head,37,c,40)
	call putline(head,41,c,41)
	call putline(head,44,c,42)
	call putline(head,52,c,43)

	write(b(44)(1:64),'(a)')
     *"TTIME   =                  601 / ELAPSED TIME (EXPOUSE+1)       "
	call putri(head,20,c,44)
        c(30,44)=c(30,44)+1

	do 20 i=1,80
	do 20 j=45,72
20	c(i,j)=32

	write(b(72)(1:64),'(a)')
     *"END                            / END OF HEADER                  "

	k=2048*2048*4
	call swap4(a,k)
	i=lnblnk(f1)+1
        f1(i:i)=char(0)
	open(1,file=f1,status='unknown')
	close(1)
	call tvwrite(f1,b,72*80,0)
	call tvwrite(f1,a,k,72*80)
	write(*,*)'outfile: ',f1
	end


	subroutine putri(a,n,b,m)
	byte a(1),b(1)
	k=(n-1)*80+12
	do 10 i1=k,k+17
10	if(a(i1).ne.32)goto 11
11	do 19 i3=k,k+17
19	if(a(i3).eq.46)goto 18
18      do 20 i2=i3-1,k,-1
20	if(a(i2).ne.32)goto 21
21	if(i1.ge.i2)return
	l=(m-1)*80+30
	do 30 i=i2,i1,-1
	b(l)=a(i)
30	l=l-1
	end

	subroutine putline(a,n,b,m)
	byte a(1),b(1)
	k=(n-1)*80
	l=(m-1)*80
	do 10 i=1,80
10	b(l+i)=a(k+i)
	end

	subroutine put0(a,n)
	byte a(1)
	k=(n-1)*80+12
	do 10 i=k,k+3
10	if(a(i).eq.32)goto 11
11	a(i)=58
	if(a(i+1).eq.32)a(i+1)=48
	if(a(i+2).eq.32)a(i+2)=48
	a(i+3)=58
	if(a(i+4).eq.32)a(i+4)=48
	if(a(i+5).eq.32)a(i+5)=48
	a(i+6)=46
	a(i+7)=48
	end

	subroutine putch(a,n,b,m)
	byte a(1),b(1)
	k=(n-1)*80+12
	do 10 i1=k,k+17
10	if(a(i1).ne.32)goto 11
11	do 20 i2=k+17,k,-1
20	if(a(i2).ne.32)goto 21
21	if(i1.ge.i2)return
	l=(m-1)*80+29
	do 30 i=i2,i1,-1
	b(l)=a(i)
30	l=l-1
	end

	subroutine putdate(a,n,b,m)
	byte a(1),b(1),cc(20)
	character*20 c
	equivalence (c,cc)
	k=(n-1)*80+12
	i=0
	do 10 i1=k,k+17
	if(a(i1).eq.47)a(i1)=32
	i=i+1
10	cc(i)=a(i1)
	read(c(1:),*)i1,i2,i3
	if(i1.gt.1900)then
	  i=mod(i1,100)
	  i1=i2
	  i2=i3
	  i3=i
	endif
	write(c(1:),'(3i3.3)')i1,i2,i3
	k=(m-1)*80+20
        cc(4)=47
	cc(7)=47
	do 20 i=2,9
20	b(i+k)=cc(i)
	end

	subroutine readata(f1,head,a,b,ia)
	byte c(2880),a(1),b(1),d(2063*2058*2)
	byte head(80*72)
	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
	k=index(ch,'NAXIS1')+26
	read(ch(k:),'(i4)')n1
	k=index(ch,'NAXIS2')+26
	read(ch(k:),'(i4)')n2
	if(ibit.ne.16.or.n1.ne.2063.or.n2.ne.2058)then
	  write(*,*)' not armenia raw data!'
	  stop
	endif
	k=index(ch,'BZERO   =')
	bzero=0.
	if(k.ne.0) read(ch(k+15:),*)bzero
	do 8 i=1,nn
8	head(i)=c(i)
	read(3,rec=2)ch
	do 9 i=1,nn
9	head(i+nn)=c(i)

 	ibit=ibit/8
	n=2
	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	d(i)=c(j)
61	close (3)
        call swap2(d,n1*n2*2)
	if(ia.le.1)call shrink2(d,b,n1,n2,bzero)
	if(ia.gt.1)call ch40(d,a,n1,n2,bzero)
	end

	subroutine shrink2(a,b,n1,n2,bzero)
	integer*2 a(n1,n2)
	integer*2 b(512*512)
	k=0
	m=4
	do 10 j=1,2048,m
	do 10 i=1,2048,m
	k=k+1
	y=0.
	do 20 i1=0,m-1
	do 20 j1=0,m-1
20	y=y+a(i+i1,j+j1)+bzero
	y=y/(m*m)
	if(y.lt.-32767)y=-32767.
	if(y.gt. 32767)y= 32767.
10	b(k)=nint(y)
	end

	subroutine ch40(a,b,n1,n2,bzero)
	integer*2 a(n1,n2)
	real b(2048,2048)
	do 10 j=1,2048
	do 10 i=1,2048
	x=a(i,j)
10	b(i,j)=x+bzero
	end

	subroutine dis(f1,map,n1,n2)
	integer*2 map(n1*n2)
	character*60 f1
	character*16 c2,a*80
	i1=-32768
	i2= 32767
	x=0.
	do 10 i=1,n1*n2
	x=x+map(i)

	if(map(i).gt.i1)i1=map(i)
10	if(map(i).lt.i2)i2=map(i)
	x=x/n1/n2
	write(*,1)n1,n2,i1,i2,x
1	format(9x,'Pixel size:',i4,' *',i4,7x,'Max,Min:',2i6,3x,'Mean',f9.1)
	if(i2.ge.0)call whitexblack(map,n1,n2,white,sigma)
	black=white+20.*sigma
	goto 14
11	write(*,*)'white,black,rat(1/2)',white,black,', 1 or 2 (q exit)'
	read(*,'(a)')a

	if(a(1:1).eq.'q'.or.a(1:1).eq.'Q')goto 13
	if(a(1:1).ne.' ')read(a(1:),*,err=11)white,black,irat
	if(c2(1:2).eq.'XW')goto 12
14	call pgbegin(0,'?',1,1 )
	call pgpap(8.5,1.)
	call pgqinf('TYPE',c2,k)
	k=irat
	if(irat.lt.0)irat=-irat
	if(irat.gt.2)irat=2
	if(irat.lt.1)irat=1
	if(k.lt.1)call pgsci(0)
	if(c2(1:2).eq.'HP')call pgslw(2)
	call pgenv(1.,float(n1),1.,float(n2),1,-1)
	call pgsci(1)
	if(k.gt.0)call pglabel(' ',' ',f1)
12	call pgxgray(map,n1,n2,1,n1,1,n2,white,black,irat)
	if(c2(1:2).eq.'XW')goto 11
	if(k.gt.0)call pgiden
13	call pgend
	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
