/usr/share/gnudatalanguage/astrolib/modfits.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 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | pro MODFITS, filename, data, header, EXTEN_NO = exten_no, ERRMSG = errmsg, $
EXTNAME = extname
;+
; NAME:
; MODFITS
; PURPOSE:
; Modify a FITS file by updating the header and/or data array.
; EXPLANATION:
; Update the data and/or header in a specified FITS extension or primary
; HDU.
;
; The size of the supplied FITS header or data array does not
; need to match the size of the existing header or data array.
;
; CALLING SEQUENCE:
; MODFITS, Filename_or_fcb, Data, [ Header, EXTEN_NO =, EXTNAME= , ERRMSG=]
;
; INPUTS:
; FILENAME/FCB = Scalar string containing either the name of the FITS file
; to be modified, or the IO file control block returned after
; opening the file with FITS_OPEN,/UPDATE. The explicit
; use of FITS_OPEN can save time if many extensions in a
; single file will be updated.
;
; DATA - data array to be inserted into the FITS file. Set DATA = 0
; to leave the data portion of the FITS file unmodified. Data
; can also be an IDL structure (e.g. as returned by MRDFITS).
; provided that it does not include IDL pointers.
;
; HEADER - FITS header (string array) to be updated in the FITS file.
;
; OPTIONAL INPUT KEYWORDS:
; A specific extension can be specified with either the EXTNAME or
; EXTEN_NO keyword
;
; EXTEN_NO - scalar integer specifying the FITS extension to modified. For
; example, specify EXTEN = 1 or /EXTEN to modify the first
; FITS extension.
; EXTNAME - string name of the extension to modify.
;
;
; OPTIONAL OUTPUT KEYWORD:
; ERRMSG - If this keyword is supplied, then any error mesasges will be
; returned to the user in this parameter rather than depending on
; on the MESSAGE routine in IDL. If no errors are encountered
; then a null string is returned.
;
; EXAMPLES:
; (1) Modify the value of the DATE keyword in the primary header of a
; file TEST.FITS.
;
; IDL> h = headfits('test.fits') ;Read primary header
; IDL> sxaddpar,h,'DATE','2015-03-23' ;Modify value of DATE
; IDL> modfits,'test.fits',0,h ;Update header only
;
; (2) Replace the values of the primary image array in 'test.fits' with
; their absolute values
;
; IDL> im = readfits('test.fits') ;Read image array
; IDL> im = abs(im) ;Take absolute values
; IDL> modfits,'test.fits',im ;Update image array
;
; (3) Add some HISTORY records to the FITS header in the first extension
; of a file 'test.fits'
;
; IDL> h = headfits('test.fits',/ext) ;Read first extension hdr
; IDL> sxaddhist,['Comment 1','Comment 2'],h
; IDL> modfits,'test.fits',0,h,/ext ;Update extension hdr
;
; (4) Change 'OBSDATE' keyword to 'OBS-DATE' in every extension in a
; FITS file. Explicitly open with FITS_OPEN to save compute time.
;
; fits_open,'test.fits',io,/update ;Faster to explicity open
; for i = 1,io.nextend do begin ;Loop over extensions
; fits_read,io,0,h,/header_only,exten_no=i,/No_PDU ;Get header
; date= sxpar(h,'OBSDATE') ;Save keyword value
; sxaddpar,h,'OBS-DATE',date,after='OBSDATE'
; sxdelpar,h,'OBSDATE' ;Delete bad keyword
; modfits,io,0,h,exten_no=i ;Update header
; endfor
;
; Note the use of the /No_PDU keyword in the FITS_READ call -- one
; does *not* want to append the primary header, if the STScI
; inheritance convention is adopted.
;
; NOTES:
; Uses the BLKSHIFT procedure to shift the contents of the FITS file if
; the new data or header differs in size by more than 2880 bytes from the
; old data or header. If a file control block (FCB) structure is
; supplied, then the values of START_HEADER, START_DATA and NBYTES may
; be modified if the file size changes.
;
; Also see the procedures FXHMODIFY to add a single FITS keyword to a
; header in a FITS files, and FXBGROW to enlarge the size of a binary
; table.
;
; RESTRICTIONS:
; (1) Cannot be used to modify the data in FITS files with random
; groups or variable length binary tables. (The headers in such
; files *can* be modified.)
;
; (2) If a data array but no FITS header is supplied, then MODFITS does
; not check to make sure that the existing header is consistent with
; the new data.
;
; (3) Does not work with compressed files
;
; (4) The Checksum keywords will not be updated if the array to be
; updated is supplied as a structure (e.g. from MRDFITS).
; PROCEDURES USED:
; Functions: N_BYTES(), SXPAR()
; Procedures: BLKSHIFT, CHECK_FITS, FITS_OPEN, FITS_READ. SETDEFAULTVALUE
;
; MODIFICATION HISTORY:
; Written, Wayne Landsman December, 1994
; Fixed possible problem when using WRITEU after READU October 1997
; New and old sizes need only be the same within multiple of 2880 bytes
; Added call to IS_IEEE_BIG() W. Landsman May 1999
; Added ERRMSG output keyword W. Landsman May 2000
; Update tests for incompatible sizes W. Landsman December 2000
; Major rewrite to use FITS_OPEN procedures W. Landsman November 2001
; Add /No_PDU call to FITS_READ call W. Landsman June 2002
; Update CHECKSUM keywords if already present in header, add padding
; if new data size is smaller than old W.Landsman December 2002
; Only check XTENSION value if EXTEN_NO > 1 W. Landsman Feb. 2003
; Correct for unsigned data on little endian machines W. Landsman Apr 2003
; Major rewrite to allow changing size of data or header W.L. Aug 2003
; Fixed case where updated header exactly fills boundary W.L. Feb 2004
; More robust error reporting W.L. Dec 2004
; Make sure input header ends with a END W.L. March 2006
; Assume since V5.5, remove VMS support, assume FITS_OPEN will
; perform byte swapping W.L. Sep 2006
; Update FCB structure if file size changes W.L. March 2007
; Fix problem when data size must be extended W.L. August 2007
; Don't assume supplied FITS header is 80 bytes W. L. Dec 2007
; Check for new END position after adding CHECKSUM W.L. July 2008
; Added EXTNAME input keyword W.L. July 2008
; Allow data to be an IDL structure A. Conley/W.L. June 2009
; Use V6.0 notation, add /NOZERO to BLKSHIFT W.L. Feb 2011
; Don't try to update Checksums when structure supplied W.L. April 2011
; Allow structure with only 1 element W.L. Feb 2012
; Don't require that a FITS header is supplied W.L. Feb 2016
;-
On_error,2 ;Return to user
compile_opt idl2
; Check for filename input
if N_params() LT 1 then begin
print,'Syntax - ' + $
'MODFITS, Filename, Data, [ Header, EXTEN_NO=, EXTNAME=, ERRMSG= ]'
return
endif
setdefaultvalue, exten_no, 0
setdefaultvalue, Header, 0
nheader = N_elements(Header)
updated = 0b
;Make sure END statement is the last line in supplied FITS header
if nheader GT 1 then begin
endline = where( strmid(Header,0,8) EQ 'END ', Nend)
if Nend EQ 0 then begin
message,/INF, $
'WARNING - An END statement has been appended to the FITS header'
Header = [ Header, 'END' + string( replicate(32b,77) ) ]
endif else header = header[0:endline]
endif
ndata = N_elements(data)
dtype = size(data,/TNAME)
printerr = ~arg_present(ERRMSG)
fcbsupplied = size(filename,/TNAME) EQ 'STRUCT'
if (nheader GT 1) && (ndata GT 1) && (dtype NE 'STRUCT') then begin
check_fits, data, header, ERRMSG = MESSAGE
if message NE '' then goto, BAD_EXIT
endif
; Open file and read header information
if (exten_no EQ 0) && (~keyword_set(EXTNAME)) then begin
if nheader GT 0 then $
if strmid( header[0], 0, 8) NE 'SIMPLE ' then begin
message = $
'Input header does not contain required SIMPLE keyword'
goto, BAD_EXIT
endif
endif else begin
if nheader GT 1 then $
if strmid( header[0], 0, 8) NE 'XTENSION' then begin
message = $
'Input header does not contain required XTENSION keyword'
goto, BAD_EXIT
endif
endelse
; Was a file name or file control block supplied?
if ~fcbsupplied then begin
fits_open, filename, io,/update,/No_Abort,message=message
if message NE '' then GOTO, BAD_EXIT
endif else begin
if filename.open_for_write EQ 0 then begin
message = 'FITS file is set for READONLY, cannot be updated'
goto, BAD_EXIT
endif
io = filename
endelse
; Getting starting position of data and header
if keyword_set(extname) then begin
exten_no = where( strupcase(io.extname) EQ strupcase(extname), Nfound)
if Nfound EQ 0 then begin
message,'Extension name ' + extname + ' not found in FITS file'
GOTO, BAD_EXIT
endif
endif
unit = io.unit
start_d = io.start_data[exten_no]
if exten_no NE io.nextend then begin
start_h = io.start_header[exten_no+1]
nbytes = start_h - start_d
endif else nbytes = N_BYTES(data)
FITS_READ,Io,0,oldheader,/header_only, exten=exten_no, /No_PDU, $
message = message,/no_abort
if message NE '' then goto, BAD_EXIT
dochecksum = sxpar(oldheader,'CHECKSUM', Count = N_checksum)
checksum = N_checksum GT 0
; Update header, including any CHECKSUM keywords if present
if nheader GT 1 then begin
noldheader = start_d - io.start_header[exten_no]
if dtype EQ 'UINT' then $
sxaddpar,header,'BZERO',32768,'Data is unsigned integer'
if dtype EQ 'ULONG' then $
sxaddpar,header,'BZERO',2147483648,'Data is unsigned long'
if checksum then begin
if (Ndata GT 1) && (dtype NE 'STRUCT') then $
FITS_ADD_CHECKSUM, header, data else $
FITS_ADD_CHECKSUM, header
endif
; Position of 'END' card may have changed - Bug fix July 2008
endline = where( strmid(Header,0,8) EQ 'END ', Nend)
newbytes = N_elements(header)*80
block = (newbytes-1)/2880 - (Noldheader-1)/2880
if block NE 0 then begin
BLKSHIFT, io.unit, start_d, block*2880L, /NOZERO
start_d += block*2880L
io.start_data[exten_no:*] += block*2880L
io.nbytes += block*2880L
if exten_no NE io.nextend then begin
start_h += block*2880L
io.start_header[exten_no+1:*] += block*2880L
endif
endif
point_lun, unit, io.start_header[exten_no] ;Position header start
bhdr = replicate(32b, newbytes)
for n = 0l, endline[0] do bhdr[80*n] = byte( header[n] )
writeu, unit, bhdr
remain = newbytes mod 2880
if remain GT 0 then writeu, unit, replicate( 32b, 2880 - remain)
updated = 1b
endif
if (ndata GT 1) || (dtype EQ 'STRUCT') then begin
newbytes = N_BYTES(data) ;total number of bytes in supplied data
block = (newbytes-1)/2880 - (nbytes-1)/2880
if (block NE 0) && (exten_no NE io.nextend) then begin
BLKSHIFT, io.unit, start_h, block*2880L,/NOZERO
io.nbytes += block*2880L
io.start_header[exten_no+1:*] += block*2880L
io.start_data[exten_no+1:*] += block*2880L
endif
if (nheader EQ 0) && (dtype NE 'STRUCT') then begin
check_fits,data,oldheader,ERRMSG = message
if message NE '' then goto, BAD_EXIT
endif
junk = fstat(unit) ;Need this before changing from READU to WRITEU
point_lun, unit, start_d
if dtype EQ 'UINT' then newdata = fix(data - 32768)
if dtype EQ 'ULONG' then newdata = long(data - 2147483648)
if N_elements(newdata) GT 0 then writeu, unit, newdata else $
writeu, unit ,data
remain = newbytes mod 2880
if remain GT 0 then begin
padnum = 0b
if exten_no GT 0 then begin
exten = sxpar( oldheader, 'XTENSION')
if exten EQ 'TABLE ' then padnum = 32b
endif
writeu, unit, replicate( padnum, 2880 - remain)
endif
updated = 1b
endif
if ~fcbsupplied then FITS_CLOSE,io else filename = io
if ~updated then message,'FITS file not modified',/INF
return
BAD_EXIT:
if N_elements(io) GT 0 then if ~fcbsupplied then fits_close,io
if printerr then message,'ERROR - ' + message,/CON else errmsg = message
if fcbsupplied then fname = filename.filename else fname = filename
message,'FITS file ' + fname + ' not modified',/INF
return
end
|