/usr/share/gnudatalanguage/astrolib/tbinfo.pro

pro tbinfo,h,tb_str, errmsg = errmsg, NOSCALE= noscale
;+
; NAME:
;       TBINFO
; PURPOSE:
;       Return an informational IDL structure from a FITS binary table header.
;
; CALLING SEQUENCE:
;       tbinfo, h, tb_str, [ERRMSG = ]
; INPUTS:
;       h - FITS binary table header, e.g. as returned by READFITS()
;
; OUTPUTS:
;       tb_str - IDL structure with extracted info from the FITS binary table
;               header.   Tags include
;       .tbcol - starting column position in bytes, integer vector
;       .width - width of the field in bytes, integer vector
;       .idltype - idltype of field, byte vector
;               7 - string, 4- real*4, 3-integer*4, 5-real*8
;       .numval - repeat count, 64 bit longword vector
;       .tunit - string unit numbers, string vector
;       .tnull - integer null value for the field, stored as a string vector
;                 so that an empty string indicates that TNULL is not present
;       .tform - format for the field, string vector
;       .ttype - field name, string vector
;       .maxval- maximum number of elements in a variable length array, long
;               vector
;       .tscal - pointer array giving the scale factor for converting to 
;                physical values, default 1.0
;       .tzero - pointer array giving the additive offset for converting to 
;                physical values, default 0.0
;       .tdisp - recommended output display format
;
;       All of the output vectors will have same number of elements, equal
;       to the number of columns in the binary table.
;
;       The .tscal and .tzero values are stored as pointers so as to preserve
;       the individual data types (e.g. float or double) which may differ 
;       in different columns.   For example, to obtain the value of TSCAL for
;       the third column use *tab_str.tscal[2]  
; OPTIONAL INPUT KEYWORD:
;       /NOSCALE - if set, then the TSCAL* and TZERO* keywords are not extracted
;            from the FITS header, and the .tscal and .tzero pointers do not
;            appear in the output structure.
; OPTIONAL OUTPUT KEYWORD:
;        ERRMSG = if present, then error messages are returned in this keyword
;            rather than displayed using the MESSAGE facility 
; PROCEDURES USED:
;       SXPAR()
; NOTES:
;       For variable length ('P' format) column, TBINFO returns values for
;       reading the 2 element longward array of pointers (numval=2, 
;       idltype = 3, width=4)
; HISTORY:
;       Major rewrite to return a structure      W. Landsman   August 1997
;       Added "unofficial" 64 bit integer "K" format W. Landsamn Feb. 2003
;       Store .tscal and .tzero tags as pointers, so as to preserve 
;       type information   W. Landsman          April 2003
;       Treat repeat count for string as specifying string length, not number
;          of elements, added ERRMSG    W. Landsman        July 2006
;       Treat logical as character string 'T' or 'F' W. Landsman  October 2006
;       Added NOSCALE keyword  W. Landsman   March 2007
;       Make .numval 64 bit for very large tables  W. Landsman   April 2014
;       Make sure XTENSION is for a FITS binary table W. Landsman  May 2017
;-
;----------------------------------------------------------------------------
 On_error,2
 compile_opt idl2
 if N_params() LT 2 then begin
        print,'Syntax - TBINFO, h, tb_str, [ERRMSG=, /NOSCALE]'
        return
 endif
 save_err = arg_present(errmsg)
 
;Make sure a FITS binary table 
  ext_type = strmid( strtrim( sxpar( h, 'XTENSION'), 2 ), 0, 8)
  if (ext_type NE 'A3DTABLE') && (ext_type NE 'BINTABLE') then begin 
  message,/INF, $
       'WARNING - XTENSION value of ' + ext_type + ' is not for a FITS Binary Table'
 endif	

; get number of fields

 tfields = sxpar( h, 'TFIELDS', COUNT = N_TFields)
 if N_TFields EQ 0 then begin    ;Legal Binary Table Header?
        errmsg = 'Invalid FITS binary table header. keyword TFIELDS is missing'
	if ~save_err then message,errmsg else return
   endif	    

 if tfields EQ 0 then begin     ;Any fields in table?
        errmsg = 'No Columns in FITS binary table, keyword TFIELDS = 0'
	if ~save_err then message,errmsg else return
  endif	    
 
; Create output arrays with default values

 idltype = intarr(tfields) & tnull = idltype
 numval = lon64arr(tfields) & tbcol = numval & width = numval & maxval = numval
 tunit = replicate('',tfields) & ttype = tunit & tdisp = tunit & tnull = tunit

 type = sxpar(h,'TTYPE*', COUNT = N_ttype)
 if N_ttype GT 0 then ttype[0] = strtrim(type,2) 

 tform = strtrim( sxpar(h,'tform*', COUNT = N_tform), 2)     ; column format
 if N_tform EQ 0 then $
        message,'Invalid FITS table header -- keyword TFORM not present
 tform =  strupcase(strtrim(tform,2))
                                                
 unit = strtrim(sxpar(h, 'TUNIT*', COUNT = N_tunit),2)     ;physical units
 if N_tunit GT 0 then tunit[0] = unit

 null = sxpar(h, 'TNULL*', COUNT = N_tnull)      ;null data value
 if N_tnull GT 0 then tnull[0] = null

 if ~keyword_set(noscale) then begin
  tscal = ptrarr(tfields,/all)
  tzero = ptrarr(tfields,/all)
  index = strtrim(indgen(tfields)+1,2)
  for i=0,tfields-1 do begin
    scale = sxpar(h,'TSCAL' + index[i], COUNT = N_tscal)     ;Scale factor
    if N_tscal GT 0 then *tscal[i] = scale else *tscal[i] = 1.0
    zero = sxpar(h,'TZERO' + index[i], Count = N_tzero)
    if N_tzero GT 0 then *tzero[i] = zero else *tzero[i] = 0
  endfor
 endif  

 disp = sxpar(h,'TDISP*', COUNT = N_tdisp)       ;Display format string
 if N_tdisp GT 0 then tdisp[0] = disp

; determine idl data type from format

 len = strlen(tform)

 for i = 0, N_elements(tform)-1 do begin

; Step through each character in the format, until a non-numerical character
; is encountered

        ichar = 0
NEXT_CHAR:
        if ichar GE len[i] then message, $
           'Invalid format specification for keyword TFORM ' + strtrim(i+1)
        char = strupcase( strmid(tform[i],ichar,1) )
        if ( (char GE '0') && ( char LE '9')) then begin
                ichar++
                goto, NEXT_CHAR
        endif

        if ichar EQ 0 then numval[i] = 1 else $
        numval[i] = strmid( tform[i], 0, ichar )

        if char EQ "P" then begin            ;Variable length array?
                char = strupcase( strmid(tform[i],ichar+1,1) )
                maxval[i] = long( strmid(tform[i],ichar+3, len[i]-ichar-4) )
                width[i] = 4  & numval[i] = 2  & idltype[i] = 3
        endif else begin

        tform[i] =  char

        case strupcase( tform[i] ) of

        'A' : begin 
	      idltype[i] = 7 &  width[i] = numval[i] & numval[i]=1 
	      end
        'I' : begin & idltype[i] = 2 &  width[i] = 2 &  end
        'J' : begin & idltype[i] = 3 &  width[i] = 4 &  end
        'E' : begin & idltype[i] = 4 &  width[i] = 4 &  end
        'D' : begin & idltype[i] = 5 &  width[i] = 8 &  end
        'L' : begin & idltype[i] = 7 &  width[i] = 1 &  end
        'B' : begin & idltype[i] = 1 &  width[i] = 1 &  end
        'C' : begin & idltype[i] = 6 &  width[i] = 8 &  end
        'M' : begin & idltype[i] = 9 &  width[i] =16 &  end
        'K' : begin & idltype[i] = 14 & width[i] = 8 &  end
;  Treat bit arrays as byte arrays with 1/8 the number of elements.

        'X' : begin
              idltype[i] = 1
              numval[i] = long((numval[i]+7)/8)
              width[i] = 1
              end

        else : message,'Invalid format specification for keyword ' + $
                        'TFORM'+ strtrim(i+1,2)
 endcase
 endelse

 if i ge 1 then tbcol[i] = tbcol[i-1] + width[i-1]*numval[i-1]

 endfor
 if keyword_set(noscale) then $ 

  tb_str = {TBCOL:tbcol,WIDTH:width,IDLTYPE:idltype,NUMVAL:numval,TUNIT:tunit,$
           TNULL:tnull,TFORM:tform,TTYPE:ttype,MAXVAL:maxval, TDISP:tdisp} $
 else $
 
 tb_str = {TBCOL:tbcol,WIDTH:width,IDLTYPE:idltype,NUMVAL:numval,TUNIT:tunit,$
           TNULL:tnull,TFORM:tform,TTYPE:ttype,MAXVAL:maxval, TSCAL:tscal, $
           TZERO:tzero, TDISP:tdisp}
 return
 end
gdl-astrolib 2018.02.16+dfsg-1 / usr / share / gnudatalanguage / astrolib / tbinfo.pro
