mwrfits.pro

来自「basic median filter simulation」· PRO 代码 · 共 1,696 行 · 第 1/4 页

           offsets = [offsets, offset]
            totalFormat = totalFormat + tf
           offset = offset + nelem
       
        endif else if sz[1] eq 7 then begin
            ; Use longest string to get appropriate size.
           strmax = max(strlen(input.(i)))
           strmaxs[i] = strmax
           tf = 'A'+strcompress(string(strmax), /remo)
           tforms = [tforms, tf]
           offsets = [offsets, offset]
            totalFormat = totalFormat + tf
           ctypes[i] = 7
           offset = offset + strmax
       
        endif else if sz[1] eq 6  or sz[1] eq 9 then begin
            ; Complexes handled as two floats.
           offset = offset + 1
       
           if sz[1] eq 6 then indx = where(types eq 'C')
           if sz[1] eq 9 then indx = where(types eq 'M')
           indx = indx[0]
           fx = formats[indx]
           if (strmid(fx, 0, 1) eq "G"  or strmid(fx, 0, 1) eq "g") then begin
               if (sz[1] eq 6) then begin
                   fx = "E"+strmid(fx,1, 99)
               endif else begin
                  fx = "D"+strmid(fx,1, 99)
               endelse
           endif
           tforms = [tforms, fx, fx]
            offsets = [offsets, offset, offset+lengths[indx]+1]
           nel = n_elements(ttypes)
           ttypes = [ttypes[0:nel-2], xtype+'_R', xtype+'_I']
           offset = offset + 2*lengths[indx] + 1

            totalFormat = totalFormat + '"[",'+formats[indx]+',1x,'+formats[indx]+',"]"'
            offset = offset+1
       
        endif else begin
         
            if sz[1] eq 1 then indx = where(types eq 'B')                      $
           else if sz[1] eq 2 or sz[1] eq 12 then indx = where(types eq 'I')  $
           else if sz[1] eq 3 or sz[1] eq 13 then indx = where(types eq 'L')  $
           else if sz[1] eq 4 then indx = where(types eq 'F')                 $
           else if sz[1] eq 5 then indx = where(types eq 'D')                 $
           else if sz[1] eq 14 or sz[1] eq 15 then indx = where(types eq 'K') $
           else begin
               print, 'MWRFITS Error: Invalid type in ASCII table'
               return
           endelse
       
           indx = indx[0]
           fx = formats[indx]
           if (strmid(fx, 0, 1) eq 'G' or strmid(fx, 0, 1) eq 'g') then begin
               if sz[1] eq 4 then begin
                   fx = 'E'+strmid(fx, 1, 99)
               endif else begin
                   fx = 'D'+strmid(fx, 1, 99)
               endelse
           endif
       
           tforms = [tforms, fx]
           offsets = [offsets, offset]
            totalFormat = totalFormat + formats[indx]
           offset = offset + lengths[indx]
        endelse
        if i ne ntag-1 then begin
            offset = offset + slen
        endif

        xsep = ", '"+separator+"', "
    
    endfor

    if  keyword_set(terminator) then begin
        sz = size(terminator);
        if sz[0] ne 0 or sz[1] ne 7 then begin
            terminator= string(10B)
        endif
    endif


    if keyword_set(terminator) then offset = offset+strlen(terminator)
    ; Write required FITS keywords.

    chk_and_upd, header, 'XTENSION', 'TABLE', 'ASCII table extension written by MWRFITS '+mwr_version()
    chk_and_upd, header, 'BITPIX', 8,'Required Value: ASCII characters'
    chk_and_upd, header, 'NAXIS', 2,'Required Value'
    chk_and_upd, header, 'NAXIS1', offset, 'Number of characters in a row'
    chk_and_upd, header, 'NAXIS2', n_elements(input), 'Number of rows'
    chk_and_upd, header, 'PCOUNT', 0, 'Required value'
    chk_and_upd, header, 'GCOUNT', 1, 'Required value'
    chk_and_upd, header, 'TFIELDS', n_elements(ttypes)-1, 'Number of fields'

    ; Recall that the TTYPES, TFORMS, and OFFSETS arrays have an
    ; initial dummy element.

    ; Write the TTYPE keywords.
    if not keyword_set(no_types) then begin
        for i=1, n_elements(ttypes)-1 do begin
            key = 'TTYPE'+ strcompress(string(i),/remo)
            if keyword_set(use_colnum) then begin
               value = 'C'+strcompress(string(i),/remo)
           endif else begin
               value = ttypes[i]+' '
           endelse
           chk_and_upd, header, key, value
        endfor

        if (not keyword_set(no_comment)) then begin
            fxaddpar, header, 'COMMENT', ' ', before='TTYPE1'
            fxaddpar, header, 'COMMENT', ' *** Column names ***', before='TTYPE1'
            fxaddpar, header, 'COMMENT', ' ', before='TTYPE1'
        endif
    
    endif

    ; Write the TBCOL keywords.

    for i=1, n_elements(ttypes)-1 do begin
        key= 'TBCOL'+strcompress(string(i),/remo)
        chk_and_upd, header, key, offsets[i]+1
    endfor

    if (not keyword_set(no_comment)) then begin
        fxaddpar, header, 'COMMENT', ' ', before='TBCOL1'
        fxaddpar, header, 'COMMENT', ' *** Column offsets ***', before='TBCOL1'
        fxaddpar, header, 'COMMENT', ' ', before='TBCOL1'
    endif

    ; Write the TFORM keywords

    for i=1, n_elements(ttypes)-1 do begin
        key= 'TFORM'+strcompress(string(i),/remo)
        chk_and_upd, header, key, tforms[i]
    endfor

    if (not keyword_set(no_comment)) then begin
        fxaddpar, header, 'COMMENT', ' ', before='TFORM1'
        fxaddpar, header, 'COMMENT', ' *** Column formats ***', before='TFORM1'
        fxaddpar, header, 'COMMENT', ' ', before='TFORM1'
    endif

    ; Write the header.

    mwr_header, lun, header

    ;  Write out the data applying the field formats

    totalFormat = "("+totalFormat+")";
    
     strings = string(input, format=totalFormat)
     if keyword_set(terminator) then strings = strings+terminator
     writeu, lun, strings
 
    ; Check to see if any padding is required.

    nbytes = n_elements(input)*offset
    padding = 2880 - nbytes mod 2880
    if padding ne 0 then writeu, lun, replicate(32b, padding)
    
   return
end

; Write a dummy primary header-data unit.
pro mwr_dummy, lun

    fxaddpar, header, 'SIMPLE', 'T','Dummy Created by MWRFITS v'+mwr_version()
    fxaddpar, header, 'BITPIX', 8, 'Dummy primary header created by MWRFITS'
    fxaddpar, header, 'NAXIS', 0, 'No data is associated with this header'
    fxaddpar, header, 'EXTEND', 'T', 'Extensions may (will!) be present'

    mwr_header, lun, header
end

; Check if this is a valid pointer array for variable length data.
function mwr_validptr, vtypes, nfld, index, array
    
    type = -1
    offset = 0L
    for i=0, n_elements(array)-1 do begin
       if ptr_valid(array[i]) then begin
           
           sz = size(*array[i])
           if sz[0] gt 1 then begin
              print,'MWRFITS: Error: Multidimensional Pointer array'
              return, 0
           endif
           if type eq -1 then begin
              type = sz[sz[0] + 1]
           endif else begin
              if sz[sz[0] + 1] ne type then begin
                  print,'MWRFITS: Error: Inconsistent type in pointer array'
                  return, 0
              endif
           endelse
           xsz = sz[1]
           if sz[0] eq 0 then xsz = 1
           offset = offset + xsz
       endif
    endfor
    if type eq -1 then begin
        ; If there is no data assume an I*2 type
       type = 2
    endif

    if  (type lt 1 or type gt 5) and (type lt 12 or type gt 15) then begin
       print,'MWRFITS: Error: Unsupported type for variable length array'
    endif

    types = 'BIJED      IJKK'
    sizes = [1,2,4,4,8,0,0,0,0,0,0,2,4,8,8]
    
    if n_elements(vtypes) eq 0 then begin
       
        vtype = {status:0, data:array,           $
            type: strmid(types, type-1, 1),            $
            itype: type, ilen: sizes[type-1],          $
            offset:offset }
    
       vtypes = replicate(vtype, nfld)

    endif else begin
       ; This ensures compatible structures without
       ; having to used named structures.
       
       vtype = vtypes[0]
       vtype.status = 0
       vtype.data   = array
       vtype.type   = strmid(types, type-1, 1)
       vtype.itype  = type
       vtype.ilen   = sizes[type-1]
       vtype.offset = offset
       vtypes[index] = vtype
       
       
    endelse
    vtypes[index].status = 1;

    return, 1
end
       
; Handle the header for a binary table.
pro mwr_tablehdr, lun, input, header, vtypes,     $
              no_types=no_types,                $
              logical_cols = logical_cols,         $
              bit_cols = bit_cols,                $
              nbit_cols= nbit_cols,             $
                no_comment=no_comment,            $
              alias=alias,                      $
              silent=silent

    if not keyword_set(no_types) then no_types = 0

    nfld = n_tags(input[0])
    if nfld le 0 then begin
       print, 'MWRFITS Error: Input contains no structure fields.'
       return
    endif

    tags = tag_names(input)

    ; Get the number of rows in the table.

    nrow = n_elements(input)

    dims    = lonarr(nfld)
    tdims   = strarr(nfld)
    types   = strarr(nfld)
    pointers= lonarr(nfld)

    ; offsets = null...  Don't want to define this
    ; in advance since reference to ulon64 won't word with IDL < 5.2
    ;
    ; Get the type and length of each column.  We do this
    ; by examining the contents of the first row of the structure.
    ;

    nbyte = 0

    for i=0, nfld-1 do begin

       a = input[0].(i)

       sz = size(a)
       
       nelem    = sz[sz[0]+2]
       type_ele = sz[sz[0]+1]
       
       if type_ele eq 7 then begin     
           maxstr = max(strlen(input.(i)) > 1 )
       endif               
       dims[i] = nelem
       
        if (sz[0] lt 1) or (sz[0] eq 1 and type_ele ne 7) then begin
           tdims[i] = ''
       endif else begin
           tdims[i] = '('
           
           if type_ele eq 7 then begin
               tdims[i] = tdims[i] + strcompress(string(maxstr), /remo) + ','
           endif
           
           for j=1, sz[0] do begin
               tdims[i] = tdims[i] + strcompress(sz[j])
               if j ne sz[0] then tdims[i] = tdims[i] + ','
           endfor
           
           tdims[i] = tdims[i] + ')'
       endelse
       
       
       case type_ele of
          1:        begin
                     types[i] = 'B'
                     nbyte = nbyte + nelem
              end
          2:       begin
                         types[i] = 'I'
                     nbyte = nbyte + 2*nelem
              end
          3:       begin
                     types[i] = 'J'
                     nbyte = nbyte + 4*nelem
              end
          4:       begin
                        types[i] = 'E'
                     nbyte = nbyte + 4*nelem
               end
          5:       begin
                     types[i] = 'D'
                     nbyte = nbyte + 8*nelem
              end
          6:       begin
                        types[i] = 'C'
                     nbyte = nbyte + 8*nelem
              end
          7:       begin
                     types[i] = 'A'
                     nbyte = nbyte + maxstr*nelem
                     dims[i] = maxstr*nelem		    
              end
          9:   begin
                       types[i] = 'M'
                     nbyte = nbyte + 16*nelem
              end

         10:   begin
                       if not mwr_validptr(vtypes, nfld, i, input.(i)) then begin
                         return
                     endif
                     
                       types[i] = 'P'+vtypes[i].type
                     nbyte = nbyte + 8
                     dims[i] = 1

                     test = mwr_unsigned_offset(vtypes[i].itype)
                     if test gt 0 then begin
                         if (n_elements(offsets) lt 1) then begin
                             offsets = ulon64arr(nfld)
                         endif
                         offsets[i] = test
                     endif
                     
               end

         12:   begin
                      types[i] = 'I'
                     if (n_elements(offsets) lt 1) then begin
                         offsets = ulon64arr(nfld)
                     endif
                     offsets[i] = mwr_unsigned_offset(12);
                     nbyte = nbyte + 2*nelem
              end

         13:   begin
                      types[i] = 'J'
                     if (n_elements(offsets) lt 1) then begin
                         offsets = ulon64arr(nfld)
                     endif
                     offsets[i] = mwr_unsigned_offset(13);
                     nbyte = nbyte + 4*nelem
              end
              
                ; 8 byte integers became standard FITS in December 2005
         14:   begin
                     types[i] = 'K'
                     nbyte = nbyte + 8*nelem
               end

         15:   begin
                      types[i] = 'K'
                     nbyte = nbyte + 8*nelem
                     if (n_elements(offsets) lt 1) then begin
                         offsets = ulon64arr(nfld)
                     endif
                     offsets[i] = mwr_unsigned_offset(15)
               end
                  
          0:   begin
                        print,'MWRFITS Error: Undefined structure element??'
                     return
              end
              
          8:   begin
                        print, 'MWRFITS Error: Nested structures'
                     return
              end
              
          else:begin
                        print, 'MWRFITS Error: Cannot parse structure'
                     return
              end
       endcase
    endfor

    ; Put in the required FITS keywords.
    chk_and_upd, header, 'XTENSION', 'BINTABLE', 'Binary table written by MWRFITS v'+mwr_version()
    chk_and_upd, header, 'BITPIX', 8, 'Required value'
    chk_and_upd, header, 'NAXIS', 2, 'Required value'
    chk_and_upd, header, 'NAXIS1', nbyte, 'Number of bytes per row'
    chk_and_upd, header, 'NAXIS2', n_elements(input), 'Number of rows'
    chk_and_upd, header, 'PCOUNT', 0, 'Normally 0 (no varying arrays)'