character*30 f0,f1,ch*1 integer*2 b(512*512) integer*2 a(2048*3*2048*3*2) ! -32 change to 16 when cal. character*80 head(72) real*8 a8(8) common /xinglong/pi,cx,cy,sphi,cphi,s0,iy,im,id,ut pi=4.*atan(1.0) cx=pi/12. cy=pi/180. phi=(40.+23/60.+36/3600.)*pi/180. ! XL latitude sphi=sin(phi) cphi=cos(phi) write(*,*) write(*,*)' Usage: tv_look [number]' write(*,*) write(*,*)' left_botton forward' write(*,*)' right_botton backward' write(*,*)' middlet_botton exit' write(*,*) i=iargc() k=1 if(i.ne.0)then call getarg(1,f1) read(f1,*)k endif call system("ls *.fit >1.1") call pgbegin(0,'/xw',1,1 ) call pgpap(5.5,1.015) call pgsci(0) call pgenv(1.,2048.,2048.,1.,0,0) call pgsci(1) 5 if(k.lt.1)k=1 open(2,file='1.1',status='old') j=0 10 read(2,'(a)',end=20)f1 j=j+1 write(*,'(i3,2a)')j,': ',f1 if(k.gt.j)goto 10 if(inqh(f1,n1,n2,head,ibit).eq.0)stop 'DATA not found' call getpar(head) c read data 11 sky=0. ipos=indexpos(head,'VOLT2 ') if(ipos.ne.73) read(head(ipos)(20:),*,err=99)sky 12 call readata(a,b,f1,ibit,sky,n1) iturn=0 if((iy-1900)*10+im.ge.945.or.iy.lt.1990)iturn=1 c turn image m1=512 m2=512 ipos=indexpos(head,'INSTRUME') if(ipos.ne.73)then do i=12,20 if(head(ipos)(i:i).eq.'3')iturn=0 if(head(ipos)(i:i).eq.'4')iturn=4 enddo endif if(iturn.eq.0)call turnx2(b,m1,m2,-180) if(iturn.eq.1)call turnx2(b,m1,m2,-360) if(iturn.eq.4)call turnx2(b,m1,m2,180) c main_job call main_job(b,f1,ch,j,n1) if(ch.eq.'D')stop if(ch.eq.'X')then close(2) k=j-1 goto 5 endif goto 10 99 sky=20001. goto 12 20 close(2) end subroutine main_job(ma,f1,ch,jj,n1) integer*2 ma(512,512) integer*2 dummy(301*301) character f1*30,ch*1,c3*18 write(c3,"(i3,': (',i4,') ')")jj,n1 ij=0 do 1089 i=100,400 do 1089 j=100,400 ij=ij+1 1089 dummy(ij)=ma(i,j) call whitexblack(dummy,301,301,white,x) black=white+20.*x call pgxgray(ma,512,512,1,512,1,512,white-5*x,black,2) call pglabel('R.A. south','Decl. east',c3//f1) x=1024 y=1024 call pgcurse(x,y,ch) call pgsci(0) call pglabel('R.A. south','Decl. east',c3//f1) call pgsci(1) end subroutine getpar(head) c get s0 iy im id ut character*80 head(72) real*8 d1,d common /xinglong/pi,cx,cy,sphi,cphi,s0,iy,im,id,ut ipos=indexpos(head,'DATE-OBS') read(head(ipos)(22:),'(i2,1x,i2,1x,i2)')id,im,iy ! read obs date iy=iy+1900 if(iy.lt.1950)iy=iy+100 ipos=indexpos(head,'TIME ') read(head(ipos)(20:),'(i2,1x,i2,1x,f4.1)')i,j,x ipos=indexpos(head,'EXPOSURE') read(head(ipos)(20:),*)k ! exp time ut=i+j/60.+x/3600.+k/7200. ! center UT time, in h call fjd(d1,1992,12,31) ! 1992,12,31 d2=(6+38/60.+40.1954/3600.)/24. ! 6 38 40.1954 x1=7+50/60.+18.344/3600. ! 7:50:18.344 lamda of XL call fjd(d,iy,im,id) d=(d-d1)*1.0027379093d0+d2 d=dmod(d,1d0) if(d.lt.0d0)d=d+1d0 s0=d*24d0 s0=s0+x1+ut*1.002738 end subroutine fjd(d,iy,im,id) real*8 d i=(im+9)*0.09 i=(i+iy-1900)*1.75+0.01 j=30.56*im j=(iy-1950)*367+id+j-i d=2433338.5d0+j end subroutine readata(a,b,f1,ibit,sky,jj) integer c(720),a(1),b(1) character*30 f1,ch*2880 equivalence (c,ch) nn=720 open(1,file=f1,status='old',access='direct',recl=nn*4) read(1,rec=1)ch n1=jj n2=jj id=jj/2048 id=id*id*120 n=1 55 k=index(ch,'END ') if(k.eq.0)then n=n+1 read(1,rec=n)ch goto 55 endif i=0 if(ibit.lt.0)ibit=-ibit k1=n+1 k2=n+(n1*n2*ibit/32-1)/nn do 60 k=k1,k2 read(1,rec=k)ch do 60 j=1,nn i=i+1 60 a(i)=c(j) close (1) if(ibit.eq.32)then call swap4(a,n1*n2*4) if(n1.eq.6144)then call shrink9(a,n1,a) n1=2048 n2=2048 endif if(n1.eq.4000)then call shrink8(a,n1,a) n1=4096 n2=4096 endif if(sky.gt.20000.)then write(*,*)'warnning: background too high!' call shdata(a,n1*n2) endif call shrink4(a,n1,n2,a) else call swap2(a,n1*n2*2) endif call shrink2(a,n1,n2,b) ! 2048*2048-->512*512 end subroutine shdata(a,n) real a(n) do 10 i=1,n 10 a(i)=a(i)*0.1 end subroutine shrink2(a,n1,n2,b) integer*2 a(n1,n2) integer*2 b(512*512) k=0 m=n1/512 do 10 j=1,n2,m do 10 i=1,n1,m k=k+1 10 b(k)=a(i,j)+32000 end subroutine shrink4(a,n1,n2,b) real a(n1*n2) integer*2 b(n1*n2) do 10 i=1,n1*n2 x=a(i) if(x.gt.32767.)x=32767. if(x.lt.0.)x=0. 10 b(i)=x end subroutine shrink8(a,n,b) real a(n,n),b(4096,4096) real c(4096,4096) do 10 j=1,n do 10 i=1,n 10 c(i,j)=a(i,j) do 20 j=1,n do 20 i=1,n 20 b(i,j)=c(i,j) end subroutine shrink9(a,n,b) real a(n,n),b(2048,2048) do 10 j=1,2048 do 10 i=1,2048 x=0. do 20 jj=-2,0 k=j*3+jj do 20 ii=-2,0 20 x=x+a(i*3+ii,k) 10 b(i,j)=x/9. end function inqh(f1,n1,n2,head,ibit) character*(*) f1 character*80 head(72) logical inqh k=index(f1,'.') if(k.eq.0)f1=f1(1:lnblnk(f1))//'.fit' inquire(file=f1,exist=inqh) if(.not.inqh)return open(1,file=f1,status='old',access='direct',recl=5760) read(1,rec=1)head read(head(2)(22:),*)ibit read(head(4)(22:),*)n1 !NAXIS1 read(head(5)(22:),*)n2 !NAXIS2 ipos=indexpos(head,'OBJECT ') write(*,'(1x,a)')head(ipos)(1:70) ! object ipos=indexpos(head,'DATE-OBS') head(ipos)(63:72)='(dd/mm/yy)' do 10 i=ipos,ipos+5 ! da.ti.ex.ra.de.ha 10 write(*,'(1x,a)')head(i)(1:78) ipos=indexpos(head,'TELESCOP') if(ipos.ne.73)head(ipos)(12:28)='BAO 60-90 SCHIMDT' ipos=indexpos(head,'BZERO ') if(ipos.ne.73)head(ipos)(1:1)='P' ipos=indexpos(head,'BSCALE ') if(ipos.ne.73)head(ipos)(1:1)='P' ipos=indexpos(head,'TIME ') if(ipos.ne.73)head(ipos)(42:57)='OF START OF OBS.' ipos=indexpos(head,'HA ') if(ipos.ne.73)head(ipos)(45:61)='OF MIDDLE OF OBS.' close (1) 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