pro fits_open,filename,fcb,write=write,append=append,update=update, $
no_abort=no_abort,message=message,hprint=hprint
;+
;
;*NAME:
; FITS_OPEN
;
;*PURPOSE:
; Opens a FITS (Flexible Image Transport System) data file.
;
;*CATEGORY:
; INPUT/OUTPUT
;
;*CALLING SEQUENCE:
; FITS_OPEN, filename, fcb
;
;*INPUTS:
; filename : name of the FITS file to open
;
;*OUTPUTS:
; fcb : (FITS Control Block) a IDL structure containing information
; concerning the file. It is an input to FITS_READ, FITS_WRITE
; and FITS_CLOSE
;
;*KEYWORD PARAMETERS:
; /WRITE: Set this keyword to open a new file for writing.
; /APPEND: Set to append to an existing file.
; /NO_ABORT: Set to return to calling program instead of a RETALL
; when an I/O error is encountered. If set, the routine will
; return with !err=-1 and a message in the keyword MESSAGE.
; If not set, FITS_OPEN will print the message and issue a RETALL
; MESSAGE = value: Output error message
; /HPRINT - print headers with routine HPRINT as they are read.
; (useful for debugging a strange file)
;
;*NOTES:
; The output FCB should be passed to the other FITS routines (FITS_OPEN,
; FITS_READ, FITS_HELP, and FITS_WRITE). It has the following structure
; when FITS_OPEN is called without /WRITE or /APPEND keywords set.
;
; FCB.FILENAME - name of the input file
; .UNIT - unit number the file is opened to
; .NEXTEND - number of extensions in the file.
; .XTENSION - string array giving the extension type for each
; extension.
; .EXTNAME - string array giving the extension name for each
; extension. (null string if not defined the extension)
; .EXTVER - vector of extension version numbers (0 if not
; defined)
; .EXTLEVEL - vector of extension levels (0 if not defined)
; .GCOUNT - vector with the number of groups in each extension.
; .PCOUNT - vector with parameter count for each group
; .BITPIX - BITPIX for each extension with values
; 8 byte data
; 16 short word integers
; 32 long word integers
; -32 IEEE floating point
; -64 IEEE double precision floating point
; .NAXIS - number of axes for each extension. (0 for null data
; units)
; .AXIS - 2-D array where axis(*,N) gives the size of each axes
; for extension N
; .START_HEADER - vector giving the starting byte in the file
; where each extension header begins
; .START_DATA - vector giving the starting byte in the file
; where the data for each extension begins
;
; .HMAIN - keyword parameters (less standard required FITS
; keywords) for the primary data unit.
; .OPEN_FOR_WRITE - flag (0= open for read, 1=open for write,
; 2=open for update)
; .LAST_EXTENSION - last extension number read.
; .RANDOM_GROUPS - 1 if the PDU is random groups format,
; 0 otherwise
;
; When FITS open is called with the /WRITE or /APPEND option, FCB
; contains:
;
; FCB.FILENAME - name of the input file
; .UNIT - unit number the file is opened to
; .NEXTEND - number of extensions in the file.
; .OPEN_FOR_WRITE - flag (1=open for write, 2=open for update)
;
;
;*EXAMPLES:
; Open a FITS file for reading:
; FITS_OPEN,'myfile.fits',fcb
;
; Open a new FITS file for output:
; FITS_OPEN,'newfile.fits',fcb,/write
; PROCEDURES USED:
; HPRINT, SXDELPAR, SXPAR()
;*HISTORY:
; Written by: D. Lindler August, 1995
; July, 1996 NICMOS Modified to allow open for overwrite
; to allow primary header to be modified
; DJL Oct. 15, 1996 corrected to properly extend AXIS when more
; than 100 extensions present
; Converted to IDL V5.0 W. Landsman September 1997
;-
;--------------------------------------------------------------------
;
; if no parameters supplied, print calling sequence
;
if n_params(0) eq 0 then begin
print,'CALLING SEQUENCE: fits_open,filename,fcb'
print,'KEYWORD PARAMETERS: write, append, no_abort, message'+ $
', hprint'
retall
endif
;
; set default keyword parameters
;
open_for_read = 1
open_for_update = 0
open_for_write = 0
open_for_overwrite = 0
if keyword_set(write) then begin
open_for_read = 0
open_for_update = 0
open_for_write = 1
open_for_overwrite = 0
end
if keyword_set(append) then begin
open_for_read = 0
open_for_write = 0
open_for_update = 1
open_for_overwrite = 0
end
if keyword_set(update) then begin
open_for_read = 1
open_for_write = 0
open_for_update = 0
open_for_overwrite = 1
end
;
; on I/O errors goto statement ioerror:
;
on_ioerror,ioerror
;
; open file
;
get_lun,unit
case 1 of
keyword_set(append): openu,unit,filename,/block
keyword_set(update): openu,unit,filename,/block
keyword_set(write) : if !version.os eq 'vms' then $
openw,unit,filename,/block,/none,2880 $
else openw,unit,filename
else : openr,unit,filename,/block
endcase
file = fstat(unit)
nbytes_in_file = file.size
;
; create vectors needed to store header information for each extention
;
n = 100
xtension = strarr(n)
extname = strarr(n)
extver = lonarr(n)
extlevel = lonarr(n)
gcount = lonarr(n)
pcount = lonarr(n)
bitpix = lonarr(n)
naxis = lonarr(n)
axis = lonarr(20,n)
start_header = lonarr(n) ; starting byte in file for header
start_data = lonarr(n) ; starting byte in file for data
;
; read and process each header in the file if open for read or update
;
extend_number = 0 ; current extention number being
; processed
position = 0L ; current byte position in file
if open_for_read or open_for_update then begin
main_header = 1 ; first header in file flag
h = bytarr(80,36,/nozero) ; read buffer
;
; loop on headers in the file
;
repeat begin
point_lun,unit,position
start = position
;
; loop on header blocks
;
first_block = 1 ; first block in header flag
repeat begin
if position+2879 ge nbytes_in_file then begin
if extend_number eq 0 then begin
message = 'EOF ecountered while reading header'
goto,error_exit
endif
print,'EOF encountered reading extension header'
print,'Only '+strtrim(extend_number-1,2) + $
' extensions processed'
goto,done_headers
endif
readu,unit,h
position = position + 2880
hdr = string(h>32b)
endline = where(strmid(hdr,0,8) eq 'END ',nend)
if nend gt 0 then hdr = hdr[0:endline[0]]
if first_block then begin
;
; check for valid header (SIMPLE keyword must be first for PDU and
; XTENSION keyword for the extensions.
;
header = hdr
keyword = strmid(header[0],0,8)
if (extend_number eq 0) and $
(keyword ne 'SIMPLE ') then begin
message = 'Invalid header, no SIMPLE keyword'
goto,error_exit
endif
if (extend_number gt 0) and $
(keyword ne 'XTENSION') then begin
print,'Invalid extension header encountered'
print,'XTENSION keyword missing'
print,'Only '+strtrim(extend_number-1,2) + $
' extensions processed'
goto,done_headers
endif
end else header = [header,hdr]
first_block = 0
end until (nend gt 0)
;
; print header if hprint set
;
if keyword_set(hprint) then hprint,header
;
; end of loop on header blocks
;
; Increase size of vectors if needed
;
if extend_number ge n then begin
xtension = [xtension,strarr(n)]
extname = [extname,strarr(n)]
extver = [extver,lonarr(n)]
extlevel = [extver,lonarr(n)]
gcount = [gcount,lonarr(n)]
pcount = [pcount,lonarr(n)]
bitpix = [bitpix,lonarr(n)]
naxis = [naxis,lonarr(n)]
old_axis = axis
axis = lonarr(20,n*2)
axis[0,0] = old_axis
start_header = [start_header,lonarr(n)]
start_data = [start_data,lonarr(n)]
n = n*2
end
;
; extract information from header
;
xtension[extend_number] = strtrim(sxpar(header,'xtension'))
st = sxpar(header,'extname')
if !err lt 0 then st = ''
extname[extend_number] = strtrim(st,2)
extver[extend_number] = sxpar(header,'extver')
extlevel[extend_number] = sxpar(header,'extlevel')
gcount[extend_number] = sxpar(header,'gcount')
pcount[extend_number] = sxpar(header,'pcount')
bitpix[extend_number] = sxpar(header,'bitpix')
nax = sxpar(header,'naxis')
naxis[extend_number] = nax
if nax gt 0 then for i=1,nax do $
axis[i-1,extend_number] = sxpar(header,'naxis'+strtrim(i,2))
start_data[extend_number] = position
start_header[extend_number] = start
;
; if first header, save without FITS required keywords
;
if extend_number eq 0 then begin
hmain = header
random_groups = sxpar(header,'groups')
sxdelpar,hmain,['SIMPLE','BITPIX','NAXIS','NAXIS1', $
'NAXIS2','NAXIS3','NAXIS4','NAXIS5', $
'NAXIS6','NAXIS7','NAXIS8','EXTEND', $
'PCOUNT','GCOUNT','GROUPS','BSCALE', $
'BZERO','NPIX1','NPIX2','PIXVALUE']
if (pcount[0] gt 0) then for i=1,pcount[0] do $
sxdelpar,hmain,['ptype','pscal','pzero']+strtrim(i,2)
endif
;
; skip past data to go to next header
;
ndata = axis[0,extend_number]
if naxis[extend_number] gt 1 then $
for i=2,naxis[extend_number] do $
ndata = ndata*axis[i-1,extend_number]
nbytes = (abs(bitpix[extend_number])/8) * $
(gcount[extend_number]>1)*(pcount[extend_number] + ndata)
position = position + (nbytes + 2879)/2880 * 2880
;
; end loop on headers
;
extend_number = extend_number + 1
end until (position ge nbytes_in_file-2879)
end
;
; point at end of file in /extend
;
done_headers:
if open_for_update then point_lun,unit,nbytes_in_file
;
; number of extentions
;
if open_for_write then nextend = -1 $
else nextend = extend_number - 1
;
; set up blank hmain if open for write
;
if open_for_write then begin
hmain = strarr(1)
hmain[0] = 'END '
end
;
; create output structure for the file control block
;
if open_for_write or open_for_update then begin
fcb = {filename:filename,unit:unit,nextend:nextend, $
open_for_write:open_for_write + open_for_update*2}
end else begin
nx = nextend
fcb = {filename:filename,unit:unit,nextend:nextend, $
xtension:xtension[0:nx],extname:extname[0:nx], $
extver:extver[0:nx],extlevel:extlevel[0:nx], $
gcount:gcount[0:nx],pcount:pcount[0:nx], $
bitpix:bitpix[0:nx],naxis:naxis[0:nx], $
axis:axis[*,0:nx], $
start_header:start_header[0:nx], $
start_data:start_data[0:nx],hmain:hmain, $
open_for_write:open_for_overwrite*3,$
last_extension:-1, $
random_groups:random_groups}
end
!err = 1
return
;
; error exit
;
ioerror:
message = !err_string
error_exit:
free_lun,unit
!err = -1
if keyword_set(no_abort) then return
print,'FITS_OPEN ERROR: '+message
retall
end
Return to the shapelets web page or the code help menu.
| Last modified on 2nd Mar 2009 by Richard Massey. |