/usr/share/gnudatalanguage/astrolib/tbhelp.pro is in gdl-astrolib 2018.02.16+dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | pro tbhelp,h, TEXTOUT = textout
;+
; NAME:
; TBHELP
; PURPOSE:
; Routine to print a description of a FITS binary table header
;
; CALLING SEQUENCE:
; TBHELP, h, [TEXTOUT = ]
;
; INPUTS:
; h - FITS header for a binary table, string array
;
; OPTIONAL INPUT KEYWORD:
; TEXTOUT - scalar number (0-7) or string (file name) controling
; output device (see TEXTOPEN). Default is TEXTOUT=1, output
; to the user's terminal
;
; METHOD:
; FITS Binary Table keywords NAXIS*,EXTNAME,TFIELDS,TTYPE*,TFORM*,TUNIT*,
; are read from the header and displayed at the terminal
;
; A FITS header is recognized as bein for a binary table if the keyword
; XTENSION has the value 'BINTABLE' or 'A3DTABLE'
;
; NOTES:
; Certain fields may be truncated in the display
; SYSTEM VARIABLES:
; Uses the non-standard system variables !TEXTOUT and !TEXTUNIT. These
; are automatically defined by TBHELP if they have not been defined
; previously.
; PROCEDURES USED:
; REMCHAR, SXPAR(), TEXTCLOSE, TEXTOPEN, ZPARCHECK
; HISTORY:
; W. Landsman February, 1991
; Parsing of a FITS binary header made more robust May, 1992
; Added TEXTOUT keyword August 1997
; Define !TEXTOUT if not already present W. Landsman November 2002
; Slightly more compact display W. Landsman August 2005
; Fix Aug 2005 error omitting TFORM display W. Landsman Sep 2005
;-
compile_opt idl2
On_error,2
if N_params() LT 1 then begin
print,'Syntax - tbhelp, hdr, [TEXTOUT= ]'
return
endif
zparcheck, 'TBHELP', h, 1, 7, 1, 'Table Header'
naxis = sxpar( h, 'NAXIS*')
if N_elements(naxis) LT 2 then $
message,'ERROR - FITS Binary table must have NAXIS = 2'
ext_type = strmid( strtrim( sxpar( h, 'XTENSION'), 2 ), 0, 8)
if (ext_type NE 'A3DTABLE') && (ext_type NE 'BINTABLE') then message, $
'WARNING - Header type of ' + ext_type + ' is not for a FITS Binary Table',/CON
n = sxpar( h, 'TFIELDS', Count = N_tfields)
if N_tfields EQ 0 then message, $
'ERROR - Required TFIELDS keyword is missing from binary table header'
tform = sxpar(h,'TFORM*', Count = N_tform) ;Get required TFORM* values
n = n > N_tform
textopen,'tbhelp',TEXTOUT=textout
printf,!TEXTUNIT,'FITS Binary Table: ' + $
'Size ',strtrim(naxis[0],2),' by ',strtrim(naxis[1],2)
extname = sxpar(h,'EXTNAME', Count=N_ext)
if N_ext GT 0 then printf,!TEXTUNIT, 'Extension Name: ',sxpar(h,'EXTNAME')
tnull = strarr(n)
tunit = tnull & ttype =tnull & tcomm = tnull
key = strmid( h, 0, 5)
for i = 1, N_elements(h)-1 do begin
case key[i] of
'TTYPE': begin
j = fix(strtrim(strmid(h[i],5,3),2))
apos = strpos( h[i], "'")
ttype[j-1] = strmid( h[i], apos+1, 20)
slash = strpos(h[i],'/')
if slash GT 0 then $
tcomm[j-1] = strcompress( strmid(h[i], slash+1, 55))
end
'TUNIT': begin
apos = strpos( h[i], "'")
tunit[fix(strtrim(strmid(h[i],5,3),2))-1] = strmid(h[i],apos+1,20)
end
'TNULL': begin
tnull[fix(strtrim(strmid(h[i],5,3),2))-1] = $
strtrim( strmid( h[i], 10, 20 ),2)
end
'END ': goto, DONE
ELSE :
endcase
endfor
DONE:
remchar,ttype,"'" & ttype = strtrim(ttype,2)
remchar,tunit,"'" & tunit = strtrim(tunit,2)
tform = strtrim(tform,2)
remchar,tnull,"'" & tnull = strtrim(tnull,2)
len_ttype = strtrim( max(strlen(ttype)) > 4,2)
len_tunit = strtrim( max(strlen(tunit)) > 4,2)
len_tform = strtrim( max(strlen(tform)) > 4,2)
len_tnull = strtrim( max(strlen(tnull)) > 4,2)
fmt = '(A5,1x,A' + len_ttype +',1x,A' + len_tunit + ',1x,A' + len_tform + $
',1x,A' + len_tnull +',1x,A)'
printf,!TEXTUNIT,'Field','Name','Unit','Frmt','Null','Comment',f=fmt
field = strtrim(sindgen(n)+1,2)
for i=0,n-1 do begin
printf,!TEXTUNIT,field[i],ttype[i],tunit[i],tform[i],tnull[i],tcomm[i], $
format=fmt
endfor
textclose, TEXTOUT = textout
return
end
|