/usr/share/gnudatalanguage/astrolib/writefits.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 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | pro writefits, filename, data, header, heap, Append = Append, Silent = Silent, $
compress = compress, CheckSum = checksum, NaNValue = NaNvalue
;+
; NAME:
; WRITEFITS
; PURPOSE:
; Write IDL array and header variables to a disk FITS file.
;
; EXPLANATION:
; A minimal FITS header is created if not supplied.
; WRITEFITS works for all types of FITS files except random groups
;
; CALLING SEQUENCE:
; WRITEFITS, filename, data [, header, /APPEND, /COMPRESS, /CHECKSUM]
;
; INPUTS:
; FILENAME = String containing the name of the file to be written.
;
; DATA = Image array to be written to FITS file. If DATA is
; undefined or a scalar, then only the FITS header (which
; must have NAXIS = 0) will be written to disk
;
; OPTIONAL INPUT:
; HEADER = String array containing the header for the FITS file.
; If variable HEADER is not given, the program will generate
; a minimal FITS header.
; HEAP - A byte array giving the heap area following, e.g. a variable
; length binary table
;
; OPTIONAL INPUT KEYWORD:
; /APPEND - If this keyword is set then the supplied header and data
; array are assumed to be an extension and are appended onto
; the end of an existing FITS file. If the file does not
; exist, then WRITEFITS will create one with a minimal primary
; header (and /EXTEND keyword) and then append the supplied
; extension header and array. Note that the primary
; header in an existing file must already have an EXTEND
; keyword to indicate the presence of an FITS extension.
; /COMPRESS - If this keyword is set, then the FITS file is written as
; a gzip compressed file. An extension '.gz' is appended to
; to the file name if it does not already exist. The /COMPRESS
; option is incompatible with the /APPEND option.
; /Checksum - If set, then the CHECKSUM keywords to monitor data integrity
; will be included in the FITS header. For more info, see
; http://fits.gsfc.nasa.gov/registry/checksum.html
; By default, checksum keywords will updated if they are already
; in the FITS header.
; NaNvalue - Value in the data array which represents missing pixels.
; This keyword should only used when missing pixels are not
; represented by NaN values in the input array.
; OUTPUTS:
; None
;
; RESTRICTIONS:
; (1) It recommended that BSCALE and BZERO not be used (or set equal
; to 1. and 0) except with integer data
; (2) WRITEFITS will remove any group parameters from the FITS header
; (3) As of Feb 2008, WRITEFITS no longer requires the primary header of a
; FITS file with extensions to contain the EXTEND keyword, consistent
; with Section 4.4.2.1 of the FITS 3.0 standard. A warning is still
; given. See http://fits.gsfc.nasa.gov/fits_standard.html
;
; EXAMPLE:
; Write a randomn 50 x 50 array as a FITS file creating a minimal header.
;
; IDL> im = randomn(seed, 50, 50) ;Create array
; IDL> writefits, 'test', im ;Write to a FITS file "test"
;
; PROCEDURES USED:
; CHECK_FITS, FITS_ADD_CHECKSUM, MKHDR, MRD_HREAD, SXDELPAR, SXADDPAR,
; SXPAR()
;
; MODIFICATION HISTORY:
; WRITTEN, Jim Wofford, January, 29 1989
; Added call to IS_IEEE_BIG() W. Landsman Apr 96
; Make sure SIMPLE is written in first line of header W. Landsman Jun 97
; Use SYSTIME() instead of !STIME W. Landsman July 97
; Create a default image extension header if needed W. Landsman June 98
; Write unsigned data types W. Landsman December 1999
; Update for IDL V5.3, add /COMPRESS keyword W. Landsman February 2000
; Correct BZERO value for unsigned data W. Landsman July 2000
; Eliminate duplication of input array if possible W. Landsman April 2001
; Use FILE_SEARCH for V5.5 or later W. Landsman April 2002
; Create the file if not already present and /APPEND is set
; W. Landsman September 2002
; Proper call to MRD_HREAD if /APPEND is set W. Landsman December 2002
; Added /CHECKSUM keyword W. Landsman December 2002
; Restored NANvalue keyword, William Thompson, October 2003
; Write BZERO in beginning of header for unsigned integers WL April 2004
; Added ability to write heap array WL October 2004
; Correct checksum if writing heap array WL November 2004
; Assume since V5.5, no VMS support, use file_search() WL September 2006
; Set nbytes variable to LONG64 for very large files WL May 2007
; Update CHECKSUM keywords if already present WL Oct 2007
; EXTEND keyword no longer required in FITS files with extensions WL Feb 2008
; Bug fix when filename ends with '.gz' and COMPRESS is used,
; the output file must be compressed S. Koposov June 2008
; Introduce V6.0 notation W.L. Nov. 2010
; Set /APPEND if XTENSION specifies a table W.L. July 2012
; Bug fix when /CHECKSUM used with unsigned data W.L. June 2013
; June 2013 bug fix introduced problem when NAXIS=0 W.L. July 2013
; Added /Silent keyword W.L. April 2016
; Support unsigned 64 bit data type W.L. January 2018
;-
compile_opt idl2
if N_params() LT 2 then begin
print,'Syntax - WRITEFITS, filename, data,[ header, /APPEND, /CHECKSUM]'
return
endif
Catch, theError
IF theError NE 0 then begin
Catch,/Cancel
void = cgErrorMsg(/quiet)
RETURN
ENDIF
; Get information about data
siz = size( data )
naxis = siz[0] ;Number of dimensions
if naxis GT 0 then nax = siz[ 1:naxis ] ;Vector of dimensions
lim = siz[ naxis+2 ] ;Total number of data points
type = siz[naxis + 1] ;Data type
;Create a primary or image extension header if not supplied by the user
if N_elements(header) LT 2 then begin
if keyword_set(append) then mkhdr, header, data, /IMAGE $
else mkhdr, header, data, /EXTEND
endif else if naxis GT 0 then $
check_FITS, data, header, /UPDATE, Silent= silent
hdr = header ;Don't modify supplied header
;If header indicates a table extension then set the append keyword
if ~keyword_set( APPEND) && ( strmid(hdr[0],0,8) EQ 'XTENSION' ) then begin
xten = strtrim(sxpar(hdr,'XTENSION'),2)
if (xten EQ 'TABLE') || (xten Eq 'BINTABLE') || (xten Eq 'A3DTABLE') $
then begin
append = 1
message,'Writing FITS table extension',/INF,NoPrint = silent
endif
endif
if ~keyword_set( APPEND) then begin
simple = 'SIMPLE = T / Written by IDL: ' $
+ systime()
hdr[0] = simple + string( replicate(32b,80-strlen(simple) ) )
sxdelpar, hdr, [ 'GCOUNT', 'GROUPS', 'PCOUNT', 'PSIZE' ] ;Remove random groups keywords
endif
; If necessary,convert unsigned to signed. Do not destroy the original data
unsigned = 0
if naxis NE 0 then begin
unsigned = (type EQ 12) || (type EQ 13) || (type EQ 15)
if unsigned then begin
if type EQ 12 then begin
sxaddpar,hdr,'BZERO',32768,' Data is Unsigned Integer', $
before = 'DATE'
newdata = fix(data - 32768)
endif else if type EQ 13 then begin
sxaddpar,hdr,'BZERO',2147483648,' Data is Unsigned Long', $
before = 'DATE'
newdata = long(data - 2147483648)
endif else if type EQ 15 then begin
offset = ulong64(2)^63
sxaddpar,hdr,'BZERO',offset,' Data is 64 bit Unsigned Long', $
before = 'DATE'
newdata = long64(data - offset )
endif
endif
; For floating or double precision test for NaN values to write
NaNtest = keyword_set(NaNvalue) && ( (type EQ 4) || (type EQ 5) )
if NaNtest then begin
NaNpts = where( data EQ NaNvalue, N_NaN)
if (N_NaN GT 0) then begin
if type EQ 4 then data[NaNpts] = !Values.F_NaN $
else if type EQ 8 then data[NaNpts] = !Values.D_NaN
endif
endif
endif
; Open file and write header information
if keyword_set( APPEND) then begin
if (strmid( hdr[0],0,8 ) NE 'XTENSION') then begin
message, $
'ERROR - "XTENSION" must be first keyword in header extension',/CON
return
endif
if ~file_test(filename) then begin ;Create default primary header
mkhdr,h0,0b,/exten
writefits,filename,0b,h0, checksum = checksum
openu, unit, filename, /GET_LUN, /swap_if_little_endian
endif else begin
openu, unit, filename, /GET_LUN, /swap_if_little_endian
mrd_hread, unit, hprimary
extend = where( strcmp(hprimary,'EXTEND ',8), Nextend)
if Nextend EQ 0 then $
message,'WARNING - EXTEND keyword not found in primary FITS header',/CON,NoPrint=silent
endelse
file = fstat(unit)
nbytes = file.size
point_lun, unit, nbytes
npad = nbytes mod 2880
if npad NE 0 then writeu, unit, replicate(32b, 2880 - npad)
endif else begin
ext = ''
if keyword_set(COMPRESS) then begin
if strlowcase(strmid(filename,2,3,/reverse)) NE '.gz' $
then ext = '.gz'
endif else compress = 0
openw, unit, filename + ext, /GET_LUN, /swap_if_little_endian, $
compress = compress
endelse
; Determine if an END line occurs, and add one if necessary
endline = where( strcmp(hdr, 'END ', 8), Nend)
if Nend EQ 0 then begin
message,'WARNING - An END statement has been appended to the FITS header',/INF,NoPrint=silent
hdr = [ hdr, 'END' + string( replicate(32b,77) ) ]
endline = N_elements(hdr) - 1
endif
; Add any CHECKSUM keywords if desired or already present
do_Checksum = keyword_set(checksum)
if ~do_checksum then test = sxpar(hdr,'CHECKSUM',count=do_checksum)
if do_checksum then begin
if unsigned then begin
if N_elements(heap) GT 0 then $
FITS_ADD_CheckSum, hdr, [newdata,heap] else $
FITS_Add_CheckSum, hdr, newdata
endif else begin
if N_elements(heap) GT 0 then $
FITS_ADD_CHECKSUM, hdr, [data,heap] else $
FITS_ADD_CHECKSUM, hdr, data
endelse
endline = where( strcmp(hdr,'END ',8), Nend)
endif
nmax = endline[0] + 1
; Convert to byte and force into 80 character lines
bhdr = replicate(32b, 80l*nmax)
for n = 0l, endline[0] do bhdr[80*n] = byte( hdr[n] )
npad = 80l*nmax mod 2880
writeu, unit, bhdr
if npad GT 0 then writeu, unit, replicate(32b, 2880 - npad)
; Write data
if naxis EQ 0 then goto, DONE
bitpix = sxpar( hdr, 'BITPIX' )
nbytes = long64( N_elements( data)) * (abs(bitpix) / 8 )
npad = nbytes mod 2880
if unsigned then writeu, unit, newdata $
else writeu, unit, data
; Write optional heap area
if N_elements(heap) GT 0 then begin
theap = sxpar(hdr,'THEAP', Count=N_Theap)
if N_Theap GT 0 then begin
offset = theap - nbytes
if offset GT 0 then begin
writeu, unit, bytarr(offset)
npad = (npad + offset) mod 2880
endif
writeu, unit, heap
npad = (npad + N_elements(heap)) mod 2880
endif
endif
; ASCII Tables padded with blanks (32b) otherwise pad with zeros
if keyword_set( APPEND) then begin
exten = sxpar( header, 'XTENSION')
padnum = exten EQ 'TABLE ' ? 32b : 0b
endif else padnum = 0b
if npad GT 0 then writeu, unit, replicate( padnum, 2880 - npad)
DONE:
free_lun, unit
return
end
|