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