c------------------------------------------ c c take a 512x512 subarray and put it c into the regular array at the right place c #define _HIFLAG_ 9999 #define _LINUX_ .true. program convert implicit none real pix_r4(1014,1014) integer*2 pix_i2(1014,1014) character*80 FILEI, FILEO integer NEXTENU character*80 FILEU character*70 INFO(10) common / fitsinfo / INFO integer NAXIS integer NAXIS1, NAXIS2 real CRPIX1, CRPIX2 character*8 field character*40 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer ia,ib,ios, k integer j character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer ii, jj integer np1, np2, npt integer nread real bscale, bzero integer bitpix character*70 HDR(25) common/HDR/HDR logical DIAG data DIAG /.false./ integer NEND integer NEXTEND integer NARG, NARGs integer i NARGs = iargc() NARG = 0 print*,'NARGs: ',NARGs 9999 continue NARG = NARG + 1 if (NARG.gt.NARGs) stop print*,'NARG : ',NARG c c------------------------------------------------------------- c call getarg(NARG,FILEI) FILEO = FILEI do i = 1, 72 if (FILEO(i:i+8).eq.'_flt.fits') . FILEO(i:i+8) = '_fll.fits' enddo print*,' FILEI: ',FILEI(1:60) print*,' FILEO: ',FILEO(1:60) open(20,file=FILEI,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') open(21,file=FILEO,status='unknown', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened' c---------------------------------------------------------- c c the zeroth extension is just the file header; read it c and output it to the output file... c ia = 0 ib = 0 001 continue ia = ia + 1 ib = ib + 1 if (DIAG) print*,'READREC: ',ia read(20,rec=ia,iostat=ios) buffc do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . ia,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+51) if (field.eq.'END ') goto 002 enddo write(21,rec=ib,iostat=ios) buffc goto 001 002 continue write(21,rec=ib,iostat=ios) buffc if (DIAG) then print*,' ' print*,'ZEROTH EXTENSION DONE...' print*,' ' endif NAXIS = 0 NAXIS1 = 0 NAXIS2 = 0 CRPIX1 = 0 CRPIX2 = 0 do NEXTEND = 1, 3 c---------------------------------------------------------- c c the zeroth extension is just the file header; read it c and output it to the output file... c 101 continue ia = ia + 1 ib = ib + 1 if (DIAG) print*,'READREC: ',ia read(20,rec=ia,iostat=ios) buffc do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . ia,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+51) if (field.eq.'NAXIS ') then read(stream,*) NAXIS if (NAXIS.ne.2) stop 'NAXIS.ne.2' endif if (field.eq.'NAXIS1 ') then read(stream,*) NAXIS1 if (NAXIS1.ne.512) stop 'NAXIS1.ne.512' write(buffc(k*80+11:k*80+80),111) endif if (field.eq.'NAXIS2 ') then read(stream,*) NAXIS2 if (NAXIS2.ne.512) stop 'NAXIS2.ne.512' write(buffc(k*80+11:k*80+80),112) endif if (field.eq.'CRPIX1 ') then read(stream,*) CRPIX1 if (CRPIX1.ne.256.0) stop 'CRPIX1.ne.256' write(buffc(k*80+11:k*80+80),113) endif if (field.eq.'CRPIX2 ') then read(stream,*) CRPIX2 if (CRPIX2.ne.256.0) stop 'CRPIX2.ne.256' write(buffc(k*80+11:k*80+80),114) endif if (field.eq.'LTV1 ') then write(buffc(k*80+11:k*80+80),115) endif if (field.eq.'LTV2 ') then write(buffc(k*80+11:k*80+80),115) endif if (field.eq.'END ') goto 102 enddo write(21,rec=ib,iostat=ios) buffc goto 101 102 continue write(21,rec=ib,iostat=ios) buffc if (DIAG) then print*,' ' if (NEXTEND.eq.1) print*,'FIRST EXTENSION DONE...' if (NEXTEND.eq.2) print*,'SECND EXTENSION DONE...' if (NEXTEND.eq.3) print*,'THIRD EXTENSION DONE...' print*,' ' print*,' NAXIS : ',NAXIS print*,' NAXIS1: ',NAXIS1 print*,' NAXIS2: ',NAXIS2 print*,' CRPIX1: ',CRPIX1 print*,' CRPIX2: ',CRPIX2 endif if (NAXIS .ne. 2.or. . NAXIS1.ne.512.or. . NAXIS2.ne.512.or. . CRPIX1.ne.256.0.or. . CRPIX2.ne.256.0) stop 'not appropos' if (NEXTEND.eq.1.or.NEXTEND.eq.2) then do ii = 0001, 1014 do jj = 0001, 1014 if (NEXTEND.eq.1) pix_r4(ii,jj) = 0.00 if (NEXTEND.eq.2) pix_r4(ii,jj) = 9999.00 enddo enddo ifirst = ia+1 i1 = ia i2 = ia nbper = 4*NAXIS1*NAXIS2 npt = NAXIS1*NAXIS2 nbyte1 = 1 nbyte2 = nbper i1 = ia+1 + nbyte1/2880 i2 = ia+1 + nbyte2/2880 if (DIAG) then print*,' i1: ',i1 print*,' i2: ',i2,i2-i1 endif do ia = i1, i2, 1 read(20,rec=ia,iostat=ios) buffc nbyte0 = (ia-ifirst)*2880+ 1 nbyteE = (ia-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call buff2pix_r4_edge(buffb,pix_r4(1+507-int(CRPIX1), . 1+507-int(CRPIX2)), . np1,npt, . 1014,1014,NAXIS1,NAXIS2) if (DIAG) write(*,1115) ia,np1,np2,npt 1115 format(1x,i8,1x,i10,1x,i10,1x,i10) enddo ia = i2 ifirst = ib+1 nbper = 4*1014*1014 npt = 1014*1014 nbyte1 = 1 nbyte2 = nbper i1 = ib+1 + nbyte1/2880 i2 = ib+1 + nbyte2/2880 if (DIAG) then print*,' i1: ',i1 print*,' i2: ',i2,i2-i1 endif do ib = i1, i2, 1 nbyte0 = (ib-ifirst)*2880+ 1 nbyteE = (ib-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call pix2buff_r4(buffb,pix_r4,np1,npt) write(21,rec=ib,iostat=ios) buffc enddo ib = i2 endif ! first or second extension if (NEXTEND.eq.3) then do ii = 0001, 1014 do jj = 0001, 1014 pix_i2(ii,jj) = 255 enddo enddo ifirst = ia+1 nbper = 2*NAXIS1*NAXIS2 npt = NAXIS1*NAXIS2 nbyte1 = 1 nbyte2 = nbper i1 = ia+1 + nbyte1/2880 i2 = ia+1 + nbyte2/2880 if (DIAG) then print*,' i1a: ',i1 print*,' i2a: ',i2,i2-i1 endif do ia = i1, i2, 1 read(20,rec=ia,iostat=ios) buffc nbyte0 = (ia-ifirst)*2880+ 1 nbyteE = (ia-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/2 + 1 np2 = (nbyteE-nbyte1)/2 + 1 call buff2pix_i2_edge(buffb, . pix_i2(1+507-int(CRPIX1), . 1+507-int(CRPIX2)), . np1,npt, . 1014,1014,NAXIS1,NAXIS2) if (DIAG) write(*,1115) ia,np1,np2,npt enddo ia = i2 ifirst = ib+1 nbper = 2*1014*1014 npt = 1014*1014 nbyte1 = 1 nbyte2 = nbper i1 = ib+1 + nbyte1/2880 i2 = ib+1 + nbyte2/2880 if (DIAG) then print*,' i1b: ',i1 print*,' i2b: ',i2,i2-i1 endif do ib = i1, i2, 1 nbyte0 = (ib-ifirst)*2880+ 1 nbyteE = (ib-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/2 + 1 np2 = (nbyteE-nbyte1)/2 + 1 call pix2buff_i2(buffb,pix_i2,np1,npt) write(21,rec=ib,iostat=ios) buffc enddo ib = i2 endif ! third extension if (DIAG) then print*,' ' print*,'---> ia_new ',ia print*,'---> ib_new ',ib print*,' ' print*,'enddo NEXTEND...',NEXTEND endif enddo!NEXTEND close(20) close(21) goto 9999 c .........1.........2.........3.........4.........5.... 111 format(' 1014 / Axis length ') 112 format(' 1014 / Axis length ') 113 format(' 512.0 / x-coordinate of reference pixel') 114 format(' 512.0 / y-coordinate of reference pixel') 115 format(' 0000 / offset in X to subsection start') 116 format(' 0000 / offset in Y to subsection start') 900 print*,'file open error.' end c------------------------------------------------------- c c subroutine buff2pix_r4_edge(buff,pix,n1,nt, . NXP,NYP,NXF,NYF) implicit none c character buff(2880) byte buff(2880) integer NXP,NYP real pix(NXP,NYP) integer n1,nt integer NXF,NYF real pbuff(720) common /sneaky/pbuff integer i integer npu, nbu integer NX, NY byte b(4) real r equivalence(r,b) do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (npu.ge.1.and.npu.le.nt) then NX = npu - (npu-1)/NXF*NXF NY = 1 + (npu-1)/NXF if (NX.le.NXP.and.NY.le.NYP) then if (.not.(_LINUX_)) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) endif if ((_LINUX_)) then b(4) = buff(nbu+1) b(3) = buff(nbu+2) b(2) = buff(nbu+3) b(1) = buff(nbu+4) endif if (npu.ge.1.and.npu.le.nt) pix(NX,NY) = r endif endif enddo return end c------------------------------------------------------- c c subroutine pix2buff_r4(buff,pix,n1,nt) implicit none byte buff(2880) real*4 pix(*) integer n1,nt byte b(4) real*4 r equivalence(r,b) integer i, npu, nbu do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (npu.ge.1.and.npu.le.nt) r = pix(npu) if (.not.(_LINUX_)) then buff(nbu+1) = b(1) buff(nbu+2) = b(2) buff(nbu+3) = b(3) buff(nbu+4) = b(4) endif if ((_LINUX_)) then buff(nbu+1) = b(4) buff(nbu+2) = b(3) buff(nbu+3) = b(2) buff(nbu+4) = b(1) endif enddo return end subroutine buff2pix_i2(buff,pix,n1,nt) implicit none byte buff(2880) integer*2 pix(*) integer n1,nt byte b(2) integer ii equivalence(ii,b) integer i, npu, nbu do i = 1, 1440 npu = n1+i-1 nbu = (i-1)*2 if (.not.(_LINUX_)) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) endif if ((_LINUX_)) then b(2) = buff(nbu+1) b(1) = buff(nbu+2) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = ii enddo return end c------------------------------------------------------- c c subroutine buff2pix_i2_edge(buff,pix,n1,nt, . NXP,NYP,NXF,NYF) implicit none byte buff(2880) integer NXP,NYP integer*2 pix(NXP,NYP) integer n1,nt integer NXF,NYF real pbuff(720) common /sneaky/pbuff integer i integer npu, nbu integer NX, NY byte b(4) integer ii equivalence(ii,b) do i = 1, 1440 npu = n1+i-1 nbu = (i-1)*2 if (npu.ge.1.and.npu.le.nt) then NX = npu - (npu-1)/NXF*NXF NY = 1 + (npu-1)/NXF if (NX.le.NXP.and.NY.le.NYP) then if (.not.(_LINUX_)) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) endif if ((_LINUX_)) then b(2) = buff(nbu+1) b(1) = buff(nbu+2) endif if (npu.ge.1.and.npu.le.nt) pix(NX,NY) = ii endif endif enddo return end subroutine pix2buff_i2(buff,pix,n1,nt) implicit none byte buff(2880) integer*2 pix(*) integer n1,nt byte b(2) integer*2 ii equivalence(ii,b) integer i, npu, nbu do i = 1, 1440 npu = n1+i-1 nbu = (i-1)*2 if (npu.ge.1.and.npu.le.nt) ii = pix(npu) if (.not.(_LINUX_)) then buff(nbu+1) = b(1) buff(nbu+2) = b(2) endif if ((_LINUX_)) then buff(nbu+1) = b(2) buff(nbu+2) = b(1) endif enddo return end