;docformat = 'rst'
; Filename = eve_read_whole_fits.pro
; CreationDate = Wed Nov 30 10:54:43 2011
; ORIGIN = SDO/EVE SPOC // LASP, University of Colorado, Boulder
; COMMENT = Only the eve_read_whole_fits.pro function was written by LASP.
; COMMENT = All other software in this package is available from GSFC.
; COMMENT = This file contains a complete package of IDL code that is
; COMMENT = known to be compatible with EVE data products.
; COMMENT = Most of the software is included with the IDL Astronomy
; COMMENT = Library maintained at GSFC. However, our data users have
; COMMENT = complained about errors and byte-swapping problems in the past,
; COMMENT = and we are addressing all of these issues with this package.
; COMMENT = Those problems are caused by from inconsistent software
; COMMENT = that is out of date. It is difficult for most people to even
; COMMENT = determine if their software is out of date since much of the
; COMMENT = needed software spread over several directories.
; COMMENT = This package is internally consistent.
; REFURL1 = http://lasp.colorado.edu/home/eve
; REFURL2 = http://idlastro.gsfc.nasa.gov/
;
;
;
;-------------------------------------------------------------
;+
; NAME:
; REPCHR
; PURPOSE:
; Replace all occurrences of one character with another in a text string.
; CATEGORY:
; CALLING SEQUENCE:
; new = repchr(old, c1, [c2])
; INPUTS:
; old = original text string. in
; c1 = character to replace. in
; c2 = character to replace it with. in
; default is space.
; KEYWORD PARAMETERS:
; OUTPUTS:
; new = edited string. out
; COMMON BLOCKS:
; NOTES:
; MODIFICATION HISTORY:
; R. Sterner. 28 Oct, 1986.
; Johns Hopkins Applied Physics Lab.
; RES 1 Sep, 1989 --- converted to SUN.
; R. Sterner, 27 Jan, 1993 --- dropped reference to array.
;
; Copyright (C) 1986, Johns Hopkins University/Applied Physics Laboratory
; This software may be used, copied, or redistributed as long as it is not
; sold and this copyright notice is reproduced on each copy made. This
; routine is provided as is without any express or implied warranties
; whatsoever. Other limitations apply as described in the file disclaimer.txt.
;:Private:
;-
FUNCTION eve_rwf_REPCHR, OLD, C1, C2, help=hlp
if (n_params(0) lt 2) or keyword_set(help) then begin
print,' Replace all occurrences of one character with another '+$
'in a text string.'
print,' new = repchr(old, c1, [c2])'
print,' old = original text string. in'
print,' c1 = character to replace. in'
print,' c2 = character to replace it with. in'
print,' default is space.'
print,' new = edited string. out'
return, -1
endif
B = BYTE(OLD) ; convert string to a byte array.
CB1 = BYTE(C1) ; convert char 1 to byte.
W = WHERE(B EQ CB1(0)) ; find occurrences of char 1.
IF W(0) EQ -1 THEN RETURN, OLD ; if none, return old string.
IF N_PARAMS(0) LT 3 THEN C2 = ' ' ; default char 2 is space.
CB2 = BYTE(C2) ; convert char 2 to byte.
B(W) = CB2(0) ; replace char 1 by char 2.
RETURN, STRING(B) ; return new string.
END
;+
; NAME:
; FITS_INFO
; PURPOSE:
; Provide information about the contents of a FITS file
; EXPLANATION:
; Information includes number of header records and size of data array.
; Applies to primary header and all extensions. Information can be
; printed at the terminal and/or stored in a common block
;
; This routine is mostly obsolete, and better results can be usually be
; performed with FITS_HELP (for display) or FITS_OPEN (to read FITS
; information into a structure)
;
; CALLING SEQUENCE:
; FITS_INFO, Filename, [ /SILENT , TEXTOUT = , N_ext =, EXTNAME= ]
;
; INPUT:
; Filename - Scalar string giving the name of the FITS file(s)
; Can include wildcards such as '*.fits', or regular expressions
; allowed by the FILE_SEARCH() function. One can also search
; gzip compressed FITS files, but their extension must
; end in .gz or .ftz.
; OPTIONAL INPUT KEYWORDS:
; /SILENT - If set, then the display of the file description on the
; terminal will be suppressed
;
; TEXTOUT - specifies output device.
; textout=1 TERMINAL using /more option
; textout=2 TERMINAL without /more option
; textout=3 <program>.prt
; textout=4 laser.tmp
; textout=5 user must open file, see TEXTOPEN
; textout=7 append to existing <program.prt> file
; textout = filename (default extension of .prt)
;
; If TEXTOUT is not supplied, then !TEXTOUT is used
; OPTIONAL OUTPUT KEYWORDS:
; N_ext - Returns an integer scalar giving the number of extensions in
; the FITS file
; extname - returns a list containing the EXTNAME keywords for each
; extension.
;
; COMMON BLOCKS
; DESCRIPTOR = File descriptor string of the form N_hdrrec Naxis IDL_type
; Naxis1 Naxis2 ... Naxisn [N_hdrrec table_type Naxis
; IDL_type Naxis1 ... Naxisn] (repeated for each extension)
; For example, the following descriptor
; 167 2 4 3839 4 55 BINTABLE 2 1 89 5
;
; indicates that the primary header containing 167 lines, and
; the primary (2D) floating point image (IDL type 4)
; is of size 3839 x 4. The first extension header contains
; 55 lines, and the byte (IDL type 1) table array is of size
; 89 x 5.
;
; The DESCRIPTOR is *only* computed if /SILENT is set.
; EXAMPLE:
; Display info about all FITS files of the form '*.fit' in the current
; directory
;
; IDL> fits_info, '*.fit'
;
; Any time a *.fit file is found which is *not* in FITS format, an error
; message is displayed at the terminal and the program continues
;
; PROCEDURES USED:
; GETTOK(), MRD_SKIP, STRN(), SXPAR(), TEXTOPEN, TEXTCLOSE
;
; SYSTEM VARIABLES:
; The non-standard system variables !TEXTOUT and !TEXTUNIT will be
; created by FITS_INFO if they are not previously defined.
;
; DEFSYSV,'!TEXTOUT',1
; DEFSYSV,'!TEXTUNIT',0
;
; See TEXTOPEN.PRO for more info
; MODIFICATION HISTORY:
; Written, K. Venkatakrishna, Hughes STX, May 1992
; Added N_ext keyword, and table_name info, G. Reichert
; Work on *very* large FITS files October 92
; More checks to recognize corrupted FITS files February, 1993
; Proper check for END keyword December 1994
; Correctly size variable length binary tables WBL December 1994
; EXTNAME keyword can be anywhere in extension header WBL January 1998
; Correctly skip past extensions with no data WBL April 1998
; Converted to IDL V5.0, W. Landsman, April 1998
; No need for !TEXTOUT if /SILENT D.Finkbeiner February 2002
; Define !TEXTOUT if needed. R. Sterner, 2002 Aug 27
; Work on gzip compressed files for V5.3 or later W. Landsman 2003 Jan
; Improve speed by only reading first 36 lines of header
; Count headers with more than 32767 lines W. Landsman Feb. 2003
; Assume since V5.3 (OPENR,/COMPRESS) W. Landsman Feb 2004
; EXTNAME keyword can be anywhere in extension header again
; WBL/S. Bansal Dec 2004
; Read more than 200 extensions WBL March 2005
; Work for FITS files with SIMPLE=F WBL July 2005
; Assume since V5.4, fstat.compress available WBL April 2006
; Added EXTNAME as an IDL keyword to return values. M. Perrin Dec 2007
; make Ndata a long64 to deal with large files. E. Hivon Mar 2008
; For GDL compatibility, first check if file is compressed before using
; OPENR,/COMPRESS B. Roukema/WL Apr 2010
;:Private:
;-
pro eve_rwf_fits_info, filename, SILENT=silent,TEXTOUT=textout, N_ext=n_ext, extname=extname
On_error,2
compile_opt idl2
COMMON descriptor,fdescript
if N_params() lt 1 then begin
print,'Syntax - FITS_INFO, filename, [/SILENT, TEXTOUT=, N_ext=, EXTNAME=]'
return
endif
defsysv,'!TEXTOUT',exists=ex ; Check if !TEXTOUT exists.
if ex eq 0 then defsysv,'!TEXTOUT',1 ; If not define it.
fil = file_search( filename, COUNT = nfiles)
if nfiles EQ 0 then message,'No files found'
; File is gzip compressed if it ends in .gz or .ftz
len = strlen(fil)
ext = strlowcase(strmid(fil,transpose(len-3),3))
compress = (ext EQ '.gz') or (ext EQ 'ftz')
silent = keyword_set( SILENT )
if ~silent then begin
if ~keyword_set( TEXTOUT ) then textout = !TEXTOUT
eve_rwf_textopen, 'FITS_INFO', TEXTOUT=textout
endif
for nf = 0, nfiles-1 do begin
file = fil[nf]
openr, lun1, file, /GET_LUN, COMPRESS = compress[nf]
N_ext = -1
fdescript = ''
nmax = 400 ; MDP was 100
extname = strarr(nmax)
ptr = 0l
START:
ON_IOerror, BAD_FILE
descript = ''
test = bytarr(8)
readu, lun1, test
if N_ext EQ -1 then begin
if string(test) NE 'SIMPLE ' then goto, BAD_FILE
simple = 1
endif else begin
if string(test) NE 'XTENSION' then goto, END_OF_FILE
simple = 0
endelse
point_lun, lun1, ptr
; Read the header
hdr = bytarr(80, 36, /NOZERO)
N_hdrblock = 1
readu, lun1, hdr
ptr = ptr + 2880
hd = string( hdr > 32b)
; Get values of BITPIX, NAXIS etc.
bitpix = eve_rwf_sxpar(hd, 'BITPIX', Count = N_BITPIX)
if N_BITPIX EQ 0 then $
message, 'WARNING - FITS header missing BITPIX keyword',/CON
Naxis = eve_rwf_sxpar( hd, 'NAXIS', Count = N_NAXIS)
if N_NAXIS EQ 0 then message, $
'WARNING - FITS header missing NAXIS keyword',/CON
exten = eve_rwf_sxpar( hd, 'XTENSION')
Ext_type = strmid( strtrim( exten ,2), 0, 8) ;Use only first 8 char
gcount = eve_rwf_sxpar( hd, 'GCOUNT') > 1
pcount = eve_rwf_sxpar( hd, 'PCOUNT')
if eve_rwf_strn(Ext_type) NE '0' then begin
if (gcount NE 1) or (pcount NE 0) then $
ext_type = 'VAR_' + ext_type
descript = descript + ' ' + Ext_type
endif
descript = descript + ' ' + eve_rwf_strn(Naxis)
case BITPIX of
8: IDL_type = 1 ; Byte
16: IDL_type = 2 ; Integer*2
32: IDL_type = 3 ; Integer*4
-32: IDL_type = 4 ; Real*4
-64: IDL_type = 5 ; Real*8
ELSE: begin
message, ' Illegal value of BITPIX = ' + eve_rwf_strn(bitpix) + $
' in header',/CON
goto, SKIP
end
endcase
if Naxis GT 0 then begin
descript = descript + ' ' + eve_rwf_strn(IDL_type)
Nax = eve_rwf_sxpar( hd, 'NAXIS*')
if N_elements(Nax) LT Naxis then begin
message, $
'ERROR - Missing required NAXISi keyword in FITS header',/CON
goto, SKIP
endif
for i = 1, Naxis do descript = descript + ' '+eve_rwf_strn(Nax[i-1])
endif
end_rec = where( strtrim(strmid(hd,0,8),2) EQ 'END')
exname = eve_rwf_sxpar(hd, 'extname', Count = N_extname)
if N_extname GT 0 then extname[N_ext+1] = exname
get_extname = (N_ext GE 0) && (N_extname EQ 0) && ~keyword_set(SILENT)
; Read header records, till end of header is reached
hdr = bytarr(80, 36, /NOZERO)
while (end_rec[0] EQ -1) && (~eof(lun1) ) do begin
readu,lun1,hdr
ptr = ptr + 2880L
hd1 = string( hdr > 32b)
end_rec = where( strtrim(strmid(hd1,0,8),2) EQ 'END')
n_hdrblock = n_hdrblock + 1
if get_extname then begin
exname = eve_rwf_sxpar(hd1, 'extname', Count = N_extname)
if N_extname GT 0 then begin
extname[N_ext+1] = exname
get_extname = 0
endif
endif
endwhile
n_hdrec = 36L*(n_hdrblock-1) + end_rec[0] + 1L ; size of header
descript = eve_rwf_strn( n_hdrec ) + descript
; If there is data associated with primary header, then find out the size
if Naxis GT 0 then begin
ndata = long64(Nax[0])
if naxis GT 1 then for i = 2, naxis do ndata=ndata*Nax[i-1]
endif else ndata = 0
nbytes = (abs(bitpix)/8) * gcount * (pcount + ndata)
nrec = long(( nbytes +2879)/ 2880)
; Check if all headers have been read
if ( simple EQ 0 ) && ( strlen(eve_rwf_strn(exten)) EQ 1) then goto, END_OF_FILE
N_ext = N_ext + 1
if N_ext GT nmax then begin
extname = [extname,strarr(nmax)]
nmax = nmax*2
endif
; Append information concerning the current extension to descriptor
fdescript = fdescript + ' ' + descript
; Check for EOF
; Skip the headers and data records
ptr = ptr + nrec*2880L
if compress[nf] then eve_rwf_MRD_skip,lun1,nrec*2880L else point_lun,lun1,ptr
if ~eof(lun1) then goto, START
;
END_OF_FILE:
extname = extname[0:N_ext] ;strip off bogus first value
;otherwise will end up with '' at end
if ~SILENT then begin
printf,!textunit,file,' has ',eve_rwf_strn(N_ext),' extensions'
printf,!textunit,'Primary header: ',eve_rwf_gettok(fdescript,' '),' records'
Naxis = eve_rwf_gettok( fdescript,' ' )
If Naxis NE '0' then begin
case eve_rwf_gettok(fdescript,' ') of
'1': image_type = 'Byte'
'2': image_type = 'Integer*2'
'3': image_type = 'Integer*4'
'4': image_type = 'Real*4'
'5': image_type = 'Real*8'
endcase
image_desc = 'Image -- ' + image_type + ' array ('
for i = 0,fix(Naxis)-1 do image_desc = image_desc + ' '+ eve_rwf_gettok(fdescript,' ')
image_desc = image_desc+' )'
endif else image_desc = 'No data'
printf,!textunit, format='(a)',image_desc
if N_ext GT 0 then begin
for i = 1,N_ext do begin
printf, !TEXTUNIT, 'Extension ' + eve_rwf_strn(i) + ' -- '+extname[i]
header_desc = ' Header : '+eve_rwf_gettok(fdescript,' ')+' records'
printf, !textunit, format = '(a)',header_desc
table_type = eve_rwf_gettok(fdescript,' ')
case table_type of
'A3DTABLE' : table_desc = 'Binary Table'
'BINTABLE' : table_desc = 'Binary Table'
'VAR_BINTABLE': table_desc = 'Variable length Binary Table'
'TABLE': table_desc = 'ASCII Table'
ELSE: table_desc = table_type
endcase
table_desc = ' ' + table_desc + ' ( '
table_dim = fix( eve_rwf_gettok( fdescript,' ') )
if table_dim GT 0 then begin
table_type = eve_rwf_gettok(fdescript,' ')
for j = 0, table_dim-1 do $
table_desc = table_desc + eve_rwf_gettok(fdescript,' ') + ' '
endif
table_desc = table_desc + ')'
printf,!textunit, format='(a)',table_desc
endfor
endif
printf, !TEXTUNIT, ' '
endif
SKIP: free_lun, lun1
endfor
if ~silent then eve_rwf_textclose, TEXTOUT=textout
return
BAD_FILE:
message, 'Error reading FITS file ' + file, /CON
goto,SKIP
end
;+
; NAME:
; FXMOVE
; PURPOSE:
; Skip to a specified extension number or name in a FITS file
;
; CALLING SEQUENCE:
; STATUS=FXMOVE(UNIT, EXT, /Silent)
; STATUS=FXMOVE(UNIT, EXTNAME, /Silent, EXT_NO=, ERRMSG= )
;
; INPUT PARAMETERS:
; UNIT = An open unit descriptor for a FITS data stream.
; EXTEN = Number of extensions to skip.
; or
; Scalar string giving extension name (in the EXTNAME keyword)
; OPTIONAL INPUT PARAMETER:
; /SILENT - If set, then any messages about invalid characters in the
; FITS file are suppressed.
; OPTIONAL OUTPUT PARAMETER:
; ERRMSG = If this keyword is present, then any error messages will be
; returned to the user in this parameter rather than
; depending on the MESSAGE routine in IDL. If no errors are
; encountered, then a null string is returned.
;
; RETURNS:
; 0 if successful.
; -1 if an error is encountered.
;
; COMMON BLOCKS:
; None.
; SIDE EFFECTS:
; Repositions the file pointer.
; PROCEDURE:
; Each FITS header is read in and parsed, and the file pointer is moved
; to where the next FITS extension header until the desired
; extension is reached.
; PROCEDURE CALLS:
; FXPAR(), MRD_HREAD, MRD_SKIP
; MODIFICATION HISTORY:
; Extracted from FXPOSIT 8-March-2000 by T. McGlynn
; Added /SILENT keyword 14-Dec-2000 by W. Landsman
; Save time by not reading the full header W. Landsman Feb. 2003
; Allow extension name to be specified, added EXT_NO, ERRMSG keywords
; W. Landsman December 2006
; Make search for EXTNAME case-independent W.Landsman March 2007
; Avoid round-off error for very large extensions N. Piskunov Dec 2007
; Assume since V6.1 (/INTEGER keyword available to PRODUCT() ) Dec 2007
; Capture error message from MRD_HREAD (must be used with post-June 2009
; version of MRD-HREAD) W. Landsman July 2009
;+
; NAME:
; FITS_INFO
; PURPOSE:
; Provide information about the contents of a FITS file
; EXPLANATION:
; Information includes number of header records and size of data array.
; Applies to primary header and all extensions. Information can be
; printed at the terminal and/or stored in a common block
;
; This routine is mostly obsolete, and better results can be usually be
; performed with FITS_HELP (for display) or FITS_OPEN (to read FITS
; information into a structure)
;
; CALLING SEQUENCE:
; FITS_INFO, Filename, [ /SILENT , TEXTOUT = , N_ext =, EXTNAME= ]
;
; INPUT:
; Filename - Scalar string giving the name of the FITS file(s)
; Can include wildcards such as '*.fits', or regular expressions
; allowed by the FILE_SEARCH() function. One can also search
; gzip compressed FITS files, but their extension must
; end in .gz or .ftz.
; OPTIONAL INPUT KEYWORDS:
; /SILENT - If set, then the display of the file description on the
; terminal will be suppressed
;
; TEXTOUT - specifies output device.
; textout=1 TERMINAL using /more option
; textout=2 TERMINAL without /more option
; textout=3 <program>.prt
; textout=4 laser.tmp
; textout=5 user must open file, see TEXTOPEN
; textout=7 append to existing <program.prt> file
; textout = filename (default extension of .prt)
;
; If TEXTOUT is not supplied, then !TEXTOUT is used
; OPTIONAL OUTPUT KEYWORDS:
; N_ext - Returns an integer scalar giving the number of extensions in
; the FITS file
; extname - returns a list containing the EXTNAME keywords for each
; extension.
;
; COMMON BLOCKS
; DESCRIPTOR = File descriptor string of the form N_hdrrec Naxis IDL_type
; Naxis1 Naxis2 ... Naxisn [N_hdrrec table_type Naxis
; IDL_type Naxis1 ... Naxisn] (repeated for each extension)
; For example, the following descriptor
; 167 2 4 3839 4 55 BINTABLE 2 1 89 5
;
; indicates that the primary header containing 167 lines, and
; the primary (2D) floating point image (IDL type 4)
; is of size 3839 x 4. The first extension header contains
; 55 lines, and the byte (IDL type 1) table array is of size
; 89 x 5.
;
; The DESCRIPTOR is *only* computed if /SILENT is set.
; EXAMPLE:
; Display info about all FITS files of the form '*.fit' in the current
; directory
;
; IDL> fits_info, '*.fit'
;
; Any time a *.fit file is found which is *not* in FITS format, an error
; message is displayed at the terminal and the program continues
;
; PROCEDURES USED:
; GETTOK(), MRD_SKIP, STRN(), SXPAR(), TEXTOPEN, TEXTCLOSE
;
; SYSTEM VARIABLES:
; The non-standard system variables !TEXTOUT and !TEXTUNIT will be
; created by FITS_INFO if they are not previously defined.
;
; DEFSYSV,'!TEXTOUT',1
; DEFSYSV,'!TEXTUNIT',0
;
; See TEXTOPEN.PRO for more info
; MODIFICATION HISTORY:
; Written, K. Venkatakrishna, Hughes STX, May 1992
; Added N_ext keyword, and table_name info, G. Reichert
; Work on *very* large FITS files October 92
; More checks to recognize corrupted FITS files February, 1993
; Proper check for END keyword December 1994
; Correctly size variable length binary tables WBL December 1994
; EXTNAME keyword can be anywhere in extension header WBL January 1998
; Correctly skip past extensions with no data WBL April 1998
; Converted to IDL V5.0, W. Landsman, April 1998
; No need for !TEXTOUT if /SILENT D.Finkbeiner February 2002
; Define !TEXTOUT if needed. R. Sterner, 2002 Aug 27
; Work on gzip compressed files for V5.3 or later W. Landsman 2003 Jan
; Improve speed by only reading first 36 lines of header
; Count headers with more than 32767 lines W. Landsman Feb. 2003
; Assume since V5.3 (OPENR,/COMPRESS) W. Landsman Feb 2004
; EXTNAME keyword can be anywhere in extension header again
; WBL/S. Bansal Dec 2004
; Read more than 200 extensions WBL March 2005
; Work for FITS files with SIMPLE=F WBL July 2005
; Assume since V5.4, fstat.compress available WBL April 2006
; Added EXTNAME as an IDL keyword to return values. M. Perrin Dec 2007
; make Ndata a long64 to deal with large files. E. Hivon Mar 2008
; For GDL compatibility, first check if file is compressed before using
; OPENR,/COMPRESS B. Roukema/WL Apr 2010
;:Private:
;-
FUNCTION eve_rwf_FXMOVE, UNIT, EXTEN, SILENT = Silent, EXT_NO = ext_no, ERRMSG=errmsg
On_error, 2
compile_opt idl2
DO_NAME = SIZE( EXTEN,/TNAME) EQ 'STRING'
PRINT_ERROR = NOT ARG_PRESENT(ERRMSG)
ERRMSG = ''
IF DO_NAME THEN BEGIN
FIRSTBLOCK = 0
EXT_NO = 9999
ENAME = STRTRIM( STRUPCASE(EXTEN), 2 )
ON_IOERROR, ALLOW_PLUN
POINT_LUN, -UNIT, DUM
ON_IOERROR, NULL
ENDIF ELSE BEGIN
FIRSTBLOCK = 1
EXT_NO = EXTEN
ENDELSE
FOR I = 1, EXT_NO DO BEGIN
;
; Read the next header, and get the number of bytes taken up by the data.
;
IF EOF(UNIT) THEN BEGIN
IF DO_NAME THEN ERRMSG = $
'Extension name ' + ename + ' not found in FITS file' ELSE ERRMSG = $
'EOF encountered while moving to specified extension'
if PRINT_ERROR then message,errmsg
RETURN, -1
ENDIF
; Can't use FXHREAD to read from pipe, since it uses
; POINT_LUN. So we read this in ourselves using mrd_hread
eve_rwf_MRD_HREAD, UNIT, HEADER, STATUS, SILENT = Silent, $
FIRSTBLOCK=FIRSTBLOCK, ERRMSG = ERRMSG
IF STATUS LT 0 THEN BEGIN
IF PRINT_ERROR THEN MESSAGE,ERRMSG ;Typo fix 04/10
RETURN, -1
ENDIF
; Get parameters that determine size of data
; region.
IF DO_NAME THEN IF I GT 1 THEN BEGIN
EXTNAME = STRTRIM(eve_rwf_SXPAR(HEADER,'EXTNAME',COUNT=N_name),2)
if N_NAME GT 0 THEN $
IF ENAME EQ STRUPCASE(EXTNAME) THEN BEGIN
EXT_NO= I-1
BLOCK = 1 + ((N_ELEMENTS(HEADER)-1)/36)
POINT_LUN, -UNIT, CURR_POSS
POINT_LUN, UNIT, CURR_POSS - BLOCK*2880
BREAK
ENDIF
ENDIF
BITPIX = eve_rwf_FXPAR(HEADER,'BITPIX')
NAXIS = eve_rwf_FXPAR(HEADER,'NAXIS')
GCOUNT = eve_rwf_FXPAR(HEADER,'GCOUNT')
IF GCOUNT EQ 0 THEN GCOUNT = 1
PCOUNT = eve_rwf_FXPAR(HEADER,'PCOUNT')
IF NAXIS GT 0 THEN BEGIN
DIMS = eve_rwf_FXPAR(HEADER,'NAXIS*') ;Read dimensions
NDATA = PRODUCT(DIMS,/INTEGER)
ENDIF ELSE NDATA = 0
NBYTES = LONG64(ABS(BITPIX) / 8) * GCOUNT * (PCOUNT + NDATA)
;
; Move to the next extension header in the file.
;
NREC = (NBYTES + 2879) / 2880
eve_rwf_MRD_SKIP, UNIT, NREC*2880L
ENDFOR
RETURN, 0
ALLOW_PLUN:
ERRMSG = $
'Extension name cannot be specified unless POINT_LUN access is available'
if PRINT_ERROR then message,errmsg
RETURN, -1
END
;+
; NAME:
; FXPOSIT
; PURPOSE:
; Return the unit number of a FITS file positioned at specified extension
; EXPLANATION:
; The FITS file will be ready to be read at the beginning of the
; specified extension. Either an extension number or extension name
; can be specified. Called by headfits.pro, mrdfits.pro
;
; Modified in March 2009 to set the /SWAP_IF_LITTLE_ENDIAN keyword
; when opening a file, and **may not be compatible with earlier versions**
; CALLING SEQUENCE:
; unit=FXPOSIT(FILE, EXT_NO_OR_NAME, /READONLY, COMPRESS=program,
; UNIXPIPE=, ERRMSG= , EXTNUM= , UNIT=, /SILENT
; /FPACK, /NO_FPACK
;
; INPUT PARAMETERS:
; FILE = FITS file name, scalar string. If an empty string is supplied
; then the user will be prompted for the file name. The user
; will also be prompted if a wild card is supplied, and more than
; one file matches the wildcard.
; EXT_NO_OR_NAME = Either the extension to be moved to (scalar
; nonnegative integer) or the name of the extension to read
; (scalar string)
;
; RETURNS:
; Unit number of file or -1 if an error is detected.
;
; OPTIONAL INPUT KEYWORD PARAMETER:
; COMPRESS - If this keyword is set and non-zero, then then treat
; the file as compressed. If 1 assume a gzipped file.
; and use IDLs internal decompression facility. For Unix
; compressed or bzip2 compressed files spawn off a process to
; decompress and use its output as the FITS stream. If the
; keyword is not 1, then use its value as a string giving the
; command needed for decompression.
; /FPACK - Signal that the file is compressed with the FPACK software.
; http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) By default,
; (FXPOSIT will assume that if the file name extension ends in
; .fz that it is fpack compressed.) The FPACK software must
; be installed on the system
; /NO_FPACK - The unit will only be used to read the FITS header. In
; that case FPACK compressed files need not be uncompressed.
; LUNIT - Integer giving the file unit number. Use this keyword if
; you want to override the default use of GET_LUN to obtain
; a unit number.
; /READONLY - If this keyword is set and non-zero, then OPENR rather
; than OPENU will be used to open the FITS file. Note that
; compressed files are always set to /READONLY
; /SILENT If set, then suppress any messages about invalid characters
; in the FITS file.
;
; OPTIONAL OUTPUT KEYWORDS:
; EXTNUM - Nonnegative integer give the extension number actually read
; Useful only if the extension was specified by name.
; ERRMSG = If this keyword is present, then any error messages will be
; returned to the user in this parameter rather than
; depending on the MESSAGE routine in IDL. If no errors are
; encountered, then a null string is returned.
; UNIXPIPE - If set to 1, then the FITS file was opened with a UNIX pipe
; rather than with the OPENR command. This is only required
; when reading a FPACK, bzip or Unix compressed file. Note
; that automatic byteswapping cannnot be set for a Unix pipe,
; since the SWAP_IF_LITTLE_ENDIAN keyword is only available for the
; OPEN command, and it is the responsibilty of the calling
; routine to perform the byteswapping.
; SIDE EFFECTS:
; Opens and returns a file unit.
; PROCEDURE:
; Open the appropriate file, or spawn a command and intercept
; the output.
; Call FXMOVE to get to the appropriate extension.
; PROCEDURE CALLS:
; FXMOVE()
; MODIFICATION HISTORY:
; Derived from William Thompson's FXFINDEND routine.
; Modified by T.McGlynn, 5-October-1994.
; Modified by T.McGlynn, 25-Feb-1995 to handle compressed
; files. Pipes cannot be accessed using FXHREAD so
; MRD_HREAD was written.
; W. Landsman 23-Apr-1997 Force the /bin/sh shell when uncompressing
; T. McGlynn 03-June-1999 Use /noshell option to get rid of processes left by spawn.
; Use findfile to retain ability to use wildcards
; W. Landsman 03-Aug-1999 Use EXPAND_TILDE under Unix to find file
; T. McGlynn 04-Apr-2000 Put reading code into FXMOVE,
; additional support for compression from D.Palmer.
; W. Landsman/D.Zarro 04-Jul-2000 Added test for !VERSION.OS EQ 'Win32' (WinNT)
; W. Landsman 12-Dec-2000 Added /SILENT keyword
; W. Landsman April 2002 Use FILE_SEARCH for V5.5 or later
; W. Landsman Feb 2004 Assume since V5.3 (OPENR,/COMPRESS available)
; W. Landsman,W. Thompson, 2-Mar-2004, Add support for BZIP2
; W. Landsman Don't leave open file if an error occurs
; W. Landsman Sep 2004 Treat FTZ extension as gzip compressed
; W. Landsman Feb 2006 Removed leading spaces (prior to V5.5)
; W. Landsman Nov 2006 Allow specification of extension name
; Added EXTNUM, ERRMSG keywords
; W. Landsman/N.Piskunov Dec 2007 Added LUNIT keyword
; W. Landsman Mar 2009 OPEN with /SWAP_IF_LITTLE_ENDIAN
; Added UNIXPIPE output keyword
; N. Rich May 2009 Check if filename is an empty string
; W. Landsman May 2009 Support FPACK compressed files
; Added /FPACK, /HEADERONLY keywords
; W.Landsman July 2009 Deprecated /HEADERONLY add /NO_FPACK
; W.Landsman July 2011 Check for SIMPLE in first 8 chars
; Use gunzip to decompress Unix. Z file since compress utility
; often not installed anymore)
;+
; NAME:
; FXPOSIT
; PURPOSE:
; Return the unit number of a FITS file positioned at specified extension
; EXPLANATION:
; The FITS file will be ready to be read at the beginning of the
; specified extension. Either an extension number or extension name
; can be specified. Called by headfits.pro, mrdfits.pro
;
; Modified in March 2009 to set the /SWAP_IF_LITTLE_ENDIAN keyword
; when opening a file, and **may not be compatible with earlier versions**
; CALLING SEQUENCE:
; unit=FXPOSIT(FILE, EXT_NO_OR_NAME, /READONLY, COMPRESS=program,
; UNIXPIPE=, ERRMSG= , EXTNUM= , UNIT=, /SILENT
; /FPACK, /NO_FPACK
;
; INPUT PARAMETERS:
; FILE = FITS file name, scalar string. If an empty string is supplied
; then the user will be prompted for the file name. The user
; will also be prompted if a wild card is supplied, and more than
; one file matches the wildcard.
; EXT_NO_OR_NAME = Either the extension to be moved to (scalar
; nonnegative integer) or the name of the extension to read
; (scalar string)
;
; RETURNS:
; Unit number of file or -1 if an error is detected.
;
; OPTIONAL INPUT KEYWORD PARAMETER:
; COMPRESS - If this keyword is set and non-zero, then then treat
; the file as compressed. If 1 assume a gzipped file.
; and use IDLs internal decompression facility. For Unix
; compressed or bzip2 compressed files spawn off a process to
; decompress and use its output as the FITS stream. If the
; keyword is not 1, then use its value as a string giving the
; command needed for decompression.
; /FPACK - Signal that the file is compressed with the FPACK software.
; http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) By default,
; (FXPOSIT will assume that if the file name extension ends in
; .fz that it is fpack compressed.) The FPACK software must
; be installed on the system
; /NO_FPACK - The unit will only be used to read the FITS header. In
; that case FPACK compressed files need not be uncompressed.
; LUNIT - Integer giving the file unit number. Use this keyword if
; you want to override the default use of GET_LUN to obtain
; a unit number.
; /READONLY - If this keyword is set and non-zero, then OPENR rather
; than OPENU will be used to open the FITS file. Note that
; compressed files are always set to /READONLY
; /SILENT If set, then suppress any messages about invalid characters
; in the FITS file.
;
; OPTIONAL OUTPUT KEYWORDS:
; EXTNUM - Nonnegative integer give the extension number actually read
; Useful only if the extension was specified by name.
; ERRMSG = If this keyword is present, then any error messages will be
; returned to the user in this parameter rather than
; depending on the MESSAGE routine in IDL. If no errors are
; encountered, then a null string is returned.
; UNIXPIPE - If set to 1, then the FITS file was opened with a UNIX pipe
; rather than with the OPENR command. This is only required
; when reading a FPACK, bzip or Unix compressed file. Note
; that automatic byteswapping cannnot be set for a Unix pipe,
; since the SWAP_IF_LITTLE_ENDIAN keyword is only available for the
; OPEN command, and it is the responsibilty of the calling
; routine to perform the byteswapping.
; SIDE EFFECTS:
; Opens and returns a file unit.
; PROCEDURE:
; Open the appropriate file, or spawn a command and intercept
; the output.
; Call FXMOVE to get to the appropriate extension.
; PROCEDURE CALLS:
; FXMOVE()
; MODIFICATION HISTORY:
; Derived from William Thompson's FXFINDEND routine.
; Modified by T.McGlynn, 5-October-1994.
; Modified by T.McGlynn, 25-Feb-1995 to handle compressed
; files. Pipes cannot be accessed using FXHREAD so
; MRD_HREAD was written.
; W. Landsman 23-Apr-1997 Force the /bin/sh shell when uncompressing
; T. McGlynn 03-June-1999 Use /noshell option to get rid of processes left by spawn.
; Use findfile to retain ability to use wildcards
; W. Landsman 03-Aug-1999 Use EXPAND_TILDE under Unix to find file
; T. McGlynn 04-Apr-2000 Put reading code into FXMOVE,
; additional support for compression from D.Palmer.
; W. Landsman/D.Zarro 04-Jul-2000 Added test for !VERSION.OS EQ 'Win32' (WinNT)
; W. Landsman 12-Dec-2000 Added /SILENT keyword
; W. Landsman April 2002 Use FILE_SEARCH for V5.5 or later
; W. Landsman Feb 2004 Assume since V5.3 (OPENR,/COMPRESS available)
; W. Landsman,W. Thompson, 2-Mar-2004, Add support for BZIP2
; W. Landsman Don't leave open file if an error occurs
; W. Landsman Sep 2004 Treat FTZ extension as gzip compressed
; W. Landsman Feb 2006 Removed leading spaces (prior to V5.5)
; W. Landsman Nov 2006 Allow specification of extension name
; Added EXTNUM, ERRMSG keywords
; W. Landsman/N.Piskunov Dec 2007 Added LUNIT keyword
; W. Landsman Mar 2009 OPEN with /SWAP_IF_LITTLE_ENDIAN
; Added UNIXPIPE output keyword
; N. Rich May 2009 Check if filename is an empty string
; W. Landsman May 2009 Support FPACK compressed files
; Added /FPACK, /HEADERONLY keywords
; W.Landsman July 2009 Deprecated /HEADERONLY add /NO_FPACK
; W.Landsman July 2011 Check for SIMPLE in first 8 chars
; Use gunzip to decompress Unix. Z file since compress utility
; often not installed anymore)
;:Private:
;-
FUNCTION eve_rwf_FXPOSIT, XFILE, EXT_NO, readonly=readonly, COMPRESS=COMPRESS, $
SILENT = Silent, EXTNUM = extnum, ERRMSG= ERRMSG, $
LUNIT = lunit, UNIXPIPE= unixpipe, FPACK= fpack, $
NO_FPACK = no_fpack,HEADERONLY=headeronly
;
On_Error,2
compile_opt idl2
;
; Check the number of parameters.
;
IF N_Params() LT 2 THEN BEGIN
PRINT,'SYNTAX: UNIT = FXPOSIT(FILE, EXT_NO, /Readonly,' + $
'ERRMSG= , /SILENT, compress=prog, LUNIT = lunit)'
RETURN,-1
ENDIF
PRINTERR = ~ARG_PRESENT(ERRMSG)
ERRMSG = ''
UNIXPIPE=0
; The /headeronly keyword has been replaced with /no_fpack
if ~keyword_set(no_fpack) then no_fpack = keyword_set(headeronly)
exten = ext_no
COUNT=0
IF XFILE[0] NE '' THEN BEGIN
FILE = FILE_SEARCH(XFILE, COUNT=COUNT)
IF COUNT GT 1 THEN $
FILE = DIALOG_PICKFILE(FILTER=XFILE, /MUST_EXIST, $
TITLE = 'Please select a FITS file')
ENDIF ELSE BEGIN
FILE =DIALOG_PICKFILE(FILTER=['*.fit*;*.fts*;*.img*;*.FIT*'], $
TITLE='Please select a FITS file',/MUST_EXIST)
ENDELSE
COUNT = N_ELEMENTS(FILE)
IF COUNT EQ 0 THEN BEGIN
ERRMSG = 'Specified FITS File not found ' + XFILE[0]
IF PRINTERR THEN MESSAGE,ERRMSG,/CON
RETURN, -1 ; Don't print anything out, just report an error
ENDIF
FILE = FILE[0]
;
; Check if logical unit number is specified explicitly.
;
IF KEYWORD_SET(LUNIT) THEN BEGIN
UNIT=LUNIT
GLUN = 0
ENDIF ELSE BEGIN
UNIT = -1
GLUN = 1
ENDELSE
;
; Check if this is a compressed file.
;
UCMPRS = ' '
IF KEYWORD_SET(compress) THEN BEGIN
IF strcompress(string(compress),/remo) eq '1' THEN BEGIN
compress = 'gunzip'
ENDIF
UCMPRS = compress;
ENDIF ELSE IF KEYWORD_SET(FPACK) THEN $
UCMPRS = 'funpack' $
ELSE BEGIN
LEN = STRLEN(FILE)
IF LEN GT 3 THEN $
tail = STRLOWCASE(STRMID(file, len-3, 3)) $
ELSE tail = ' '
IF STRMID(tail,1,2) EQ '.z' THEN $
UCMPRS = 'gunzip' $
ELSE IF (tail EQ '.gz') || (tail EQ 'ftz') THEN $
UCMPRS = 'gzip' $
ELSE IF tail EQ 'bz2' THEN $
UCMPRS = 'bunzip2' $
ELSE IF ~KEYWORD_SET(NO_FPACK) THEN $
IF tail EQ '.fz' THEN UCMPRS = 'funpack'
ENDELSE
; Handle compressed files which are always opened for Read only.
IF UCMPRS EQ 'gzip' THEN BEGIN
OPENR, UNIT, FILE, /COMPRESS, GET_LUN=glun, ERROR = ERROR, $
/SWAP_IF_LITTLE
IF ERROR NE 0 THEN BEGIN
IF PRINTERR THEN PRINT,!ERROR_STATE.MSG ELSE $
ERRMSG = !ERROR_STATE.MSG
RETURN,-1
ENDIF
ENDIF ELSE IF UCMPRS NE ' ' THEN BEGIN
; Handle FPACK compressed file. If an extension name is supplied then
; first recursively call FXPOSIT to get the extension number. Then open
; the bidirectional pipe.
if UCMPRS EQ 'funpack' then begin
if size(exten,/TNAME) EQ 'STRING' THEN BEGIN
unit = eve_rwf_fxposit( file, ext_no, /no_fpack,extnum=extnum)
free_lun,unit
exten = extnum
endif
SPAWN, [UCMPRS,'-S',FILE], UNIT=UNIT, /NOSHELL
ENDIF else $
SPAWN, [UCMPRS,'-c',FILE], UNIT=UNIT, /NOSHELL
UNIXPIPE = 1
ENDIF ELSE BEGIN
;
; Go to the start of the file.
;
IF KEYWORD_SET(READONLY) THEN $
OPENR, UNIT, FILE, GET_LUN=glun, ERROR = ERROR, $
/SWAP_IF_LITTLE ELSE $
OPENU, UNIT, FILE, GET_LUN=glun, ERROR = ERROR, $
/SWAP_IF_LITTLE
IF ERROR NE 0 THEN BEGIN
IF PRINTERR THEN PRINT,!ERROR_STATE.MSG ELSE $
ERRMSG = !ERROR_STATE.MSG
RETURN,-1
ENDIF
ENDELSE
IF SIZE(EXT_NO,/TNAME) NE 'STRING' THEN $
IF EXT_NO LE 0 THEN RETURN, UNIT
;For Uncompresed files test that the first 8 characters are 'SIMPLE'
IF ucmprs EQ ' ' THEN BEGIN
simple = BytArr(6)
READU,unit,simple
if string(simple) NE 'SIMPLE' then begin
IF ~KEYWORD_SET(LUNIT) THEN Free_Lun, unit
ERRMSG = "ERROR - FITS File must begin with 'SIMPLE'"
if printerr THEN MESSAGE,errmsg,/CON
return,-1
endif
point_lun,unit,0
endif
stat = eve_rwf_FXMOVE(unit, exten, SILENT = Silent, EXT_NO = extnum, $
ERRMSG=errmsg)
IF stat LT 0 THEN BEGIN
IF ~KEYWORD_SET(LUNIT) THEN Free_Lun, unit
IF PrintErr THEN MESSAGE,ErrMsg
RETURN, stat
ENDIF ELSE RETURN, unit
END
;+
; NAME:
; MRD_HREAD
;
; PURPOSE:
; Reads a FITS header from an opened disk file or Unix pipe
; EXPLANATION:
; Like FXHREAD but also works with compressed Unix files
;
; CALLING SEQUENCE:
; MRD_HREAD, UNIT, HEADER [, STATUS, /SILENT, ERRMSG =, /FIRSTBLOCK ]
; INPUTS:
; UNIT = Logical unit number of an open FITS file
; OUTPUTS:
; HEADER = String array containing the FITS header.
; OPT. OUTPUTS:
; STATUS = Condition code giving the status of the read. Normally, this
; is zero, but is set to -1 if an error occurs, or if the
; first byte of the header is zero (ASCII null).
; OPTIONAL KEYWORD INPUT:
; /FIRSTBLOCK - If set, then only the first block (36 lines or less) of
; the FITS header are read into the output variable. If only
; size information (e.g. BITPIX, NAXIS) is needed from the
; header, then the use of this keyword can save time. The
; file pointer is still positioned at the end of the header,
; even if the /FIRSTBLOCK keyword is supplied.
; /SILENT - If set, then warning messages about any invalid characters in
; the header are suppressed.
; /SKIPDATA - If set, then the file point is positioned at the end of the
; HDU after the header is read, i.e. the following data block
; is skipped. Useful, when one wants to the read the headers
; of multiple extensions.
; OPTIONAL OUTPUT PARAMETER:
; ERRMSG = If this keyword is present, then any error messages will be
; returned to the user in this parameter rather than
; depending on the MESSAGE routine in IDL. If no errors are
; encountered, then a null string is returned.
; RESTRICTIONS:
; The file must already be positioned at the start of the header. It
; must be a proper FITS file.
; SIDE EFFECTS:
; The file ends by being positioned at the end of the FITS header, unless
; an error occurs.
; REVISION HISTORY:
; Written, Thomas McGlynn August 1995
; Modified, Thomas McGlynn January 1996
; Changed MRD_HREAD to handle Headers which have null characters
; A warning message is printed out but the program continues.
; Previously MRD_HREAD would fail if the null characters were
; not in the last 2880 byte block of the header. Note that
; such characters are illegal in the header but frequently
; are produced by poor FITS writers.
; Added /SILENT keyword W. Landsman December 2000
; Added /FIRSTBLOCK keyword W. Landsman February 2003
; Added ERRMSG, SKIPDATA keyword W. Landsman April 2009
; Close file unit even after error message W.L. October 2010
;:Private:
;-
pro eve_rwf_mrd_hread, unit, header, status, SILENT = silent, FIRSTBLOCK = firstblock, $
ERRMSG = errmsg,SKIPDATA=skipdata
On_error,2
compile_opt idl2
printerr = ~arg_present(errmsg)
errmsg = ''
block = string(replicate(32b, 80, 36))
Nend = 0 ;Signal if 'END ' statement is found
nblock = 0
while Nend EQ 0 do begin
; Shouldn't get eof in middle of header.
if eof(unit) then begin
errmsg = 'EOF encountered in middle of FITS header'
if printerr then message,errmsg,/CON
free_lun, unit
status = -1
return
endif
on_ioerror, error_return
readu, unit, block
on_ioerror, null
; Check that there aren't improper null characters in strings that are causing
; them to be truncated. Issue a warning but continue if problems are found.
w = where(strlen(block) ne 80, Nbad)
if (Nbad GT 0) then begin
if ~keyword_set(SILENT) then message, /INF, $
'Warning-Invalid characters in header'
block[w] = string(replicate(32b, 80))
endif
w = where(strmid(block, 0, 8) eq 'END ', Nend)
if nblock EQ 0 then begin
header = Nend GT 0 ? block[ 0:w[0] ] : block
nblock = nblock + 1
endif else $
if ~keyword_set(firstblock) then $
header = Nend GT 0 ? [header,block[0:w[0]]] : [header, block]
endwhile
if keyword_set(skipdata) then begin
bitpix = eve_rwf_FXpar(header,'bitpix')
naxis = eve_rwf_FXpar(header,'naxis')
gcount = eve_rwf_FXpar(header,'gcount')
if gcount eq 0 then gcount = 1
pcount = eve_rwf_FXpar(header,'pcount')
if naxis gt 0 then begin
dims = eve_rwf_FXpar(header,'naxis*') ;read dimensions
ndata = product(dims,/integer)
endif else ndata = 0
nbytes = long64(abs(bitpix) / 8) * gcount * (pcount + ndata)
eve_rwf_MRD_skip, unit, nbytes
endif
status = 0
return
error_return:
status = -1
errmsg = 'END Statement not found in FITS header'
if printerr then message, 'ERROR ' + errmsg
return
end
;+
;:Private:
;-
PRO eve_rwf_mrd_fxpar, hdr, xten, nfld, nrow, rsize, fnames, fforms, scales, offsets
compile_opt idl2, hidden
;
; Check for valid header. Check header for proper attributes.
;
S = SIZE(HDR)
IF ( S[0] NE 1 ) OR ( S[2] NE 7 ) THEN $
MESSAGE,'FITS Header (first parameter) must be a string array'
xten = eve_rwf_FXpar(hdr, 'XTENSION')
nfld = eve_rwf_FXpar(hdr, 'TFIELDS')
nrow = long64(eve_rwf_FXpar(hdr, 'NAXIS2'))
rsize = long64(eve_rwf_FXpar(hdr, 'NAXIS1'))
;; will extract these for each
names = ['TTYPE','TFORM', 'TSCAL', 'TZERO']
nnames = n_elements(names)
; Start by looking for the required TFORM keywords. Then try to extract it
; along with names (TTYPE), scales (TSCAL), and offsets (TZERO)
keyword = STRMID( hdr, 0, 8)
;
; Find all instances of 'TFORM' followed by
; a number. Store the positions of the located keywords in mforms, and the
; value of the number field in n_mforms
;
mforms = WHERE(STRPOS(keyword,'TFORM') GE 0, n_mforms)
if n_mforms GT nfld then begin
message,/CON, $
'WARNING - More columns found in binary table than specified in TFIELDS'
n_mforms = nfld
mforms = mforms[0:nfld-1]
endif
IF ( n_mforms GT 0 ) THEN BEGIN
numst= STRMID(hdr[mforms], 5 ,3)
igood = WHERE(eve_rwf_valid_num(numst,/INTEGER), n_mforms)
IF n_mforms GT 0 THEN BEGIN
mforms = mforms[igood]
number = fix( numst[igood])
numst = numst[igood]
ENDIF
ENDIF ELSE RETURN ;No fields in binary table
;; The others
fnames = strarr(n_mforms)
fforms = strarr(n_mforms)
scales = dblarr(n_mforms)
offsets = dblarr(n_mforms)
;;comments = strarr(n_mnames)
fnames_names = 'TTYPE'+numst
scales_names = 'TSCAL'+numst
offsets_names = 'TZERO'+numst
number = number -1 ;Make zero-based
eve_rwf_match, keyword, fnames_names, mkey_names, mnames, count = N_mnames
eve_rwf_match, keyword, scales_names, mkey_scales, mscales, count = N_mscales
eve_rwf_match, keyword, offsets_names, mkey_offsets, moffsets,count = N_moffsets
FOR in=0L, nnames-1 DO BEGIN
CASE names[in] OF
'TTYPE': BEGIN
tmatches = mnames
matches = mkey_names
nmatches = n_mnames
result = fnames
END
'TFORM': BEGIN
tmatches = lindgen(n_mforms)
matches = mforms
nmatches = n_mforms
result = fforms
END
'TSCAL': BEGIN
tmatches = mscales
matches = mkey_scales
nmatches = n_mscales
result = scales
END
'TZERO': BEGIN
tmatches = moffsets
matches = mkey_offsets
nmatches = n_moffsets
result = offsets
END
ELSE: message,'What?'
ENDCASE
;;help,matches,nmatches
;
; Extract the parameter field from the specified header lines. If one of the
; special cases, then done.
;
IF nmatches GT 0 THEN BEGIN
;; "matches" is a subscript for hdr and keyword.
;; get just the matches in line
line = hdr[matches]
svalue = STRTRIM( STRMID(line,9,71),2)
FOR i = 0, nmatches-1 DO BEGIN
IF ( STRMID(svalue[i],0,1) EQ "'" ) THEN BEGIN
;; Its a string
test = STRMID( svalue[i],1,STRLEN( svalue[i] )-1)
next_char = 0
off = 0
value = ''
;
; Find the next apostrophe.
;
NEXT_APOST:
endap = STRPOS(test, "'", next_char)
IF endap LT 0 THEN MESSAGE, $
'WARNING: Value of '+nam+' invalid in '+ " (no trailing ')", /info
value = value + STRMID( test, next_char, endap-next_char )
;
; Test to see if the next character is also an apostrophe. If so, then the
; string isn't completed yet. Apostrophes in the text string are signalled as
; two apostrophes in a row.
;
IF STRMID( test, endap+1, 1) EQ "'" THEN BEGIN
value = value + "'"
next_char = endap+2
GOTO, NEXT_APOST
ENDIF
;
; If not a string, then separate the parameter field from the comment field.
;
ENDIF ELSE BEGIN
;; not a string
test = svalue[I]
slash = STRPOS(test, "/")
IF slash GT 0 THEN test = STRMID(test, 0, slash)
;
; Find the first word in TEST. Is it a logical value ('T' or 'F')?
;
test2 = test
value = eve_rwf_gettok(test2,' ')
test2 = STRTRIM(test2,2)
IF ( value EQ 'T' ) THEN BEGIN
value = 1
END ELSE IF ( value EQ 'F' ) THEN BEGIN
value = 0
END ELSE BEGIN
;
; Test to see if a complex number. It's a complex number if the value and the
; next word, if any, both are valid numbers.
;
IF STRLEN(test2) EQ 0 THEN GOTO, NOT_COMPLEX
test2 = eve_rwf_gettok(test2,' ')
IF eve_rwf_valid_num(value,val1) && eve_rwf_valid_num(value2,val2) $
THEN BEGIN
value = COMPLEX(val1,val2)
GOTO, GOT_VALUE
ENDIF
;
; Not a complex number. Decide if it is a floating point, double precision,
; or integer number. If an error occurs, then a string value is returned.
; If the integer is not within the range of a valid long value, then it will
; be converted to a double.
;
NOT_COMPLEX:
ON_IOERROR, GOT_VALUE
value = test
IF ~eve_rwf_valid_num(value) THEN GOTO, GOT_VALUE
IF (STRPOS(value,'.') GE 0) || (STRPOS(value,'E') $
GE 0) || (STRPOS(value,'D') GE 0) THEN BEGIN
IF ( STRPOS(value,'D') GT 0 ) || $
( STRLEN(value) GE 8 ) THEN BEGIN
value = DOUBLE(value)
END ELSE value = FLOAT(value)
ENDIF ELSE BEGIN
lmax = long64(2)^31 - 1
lmin = -long64(2)^31
value = long64(value)
if (value GE lmin) && (value LE lmax) THEN $
value = LONG(value)
ENDELSE
;
GOT_VALUE:
ON_IOERROR, NULL
ENDELSE
ENDELSE ; if string
;
; Add to vector if required.
;
result[tmatches[i]] = value
ENDFOR
CASE names[in] OF
'TTYPE': fnames[number] = strtrim(result, 2)
'TFORM': fforms[number] = strtrim(result, 2)
'TSCAL': scales[number] = result
'TZERO': offsets[number] = result
ELSE: message,'What?'
ENDCASE
;
; Error point for keyword not found.
;
ENDIF
;
ENDFOR
END
;+
; Get a tag name give the column name and index
;:Private:
;-
function eve_rwf_mrd_dofn, name, index, use_colnum, alias=alias
compile_opt idl2, hidden
; Check if the user has specified an alias.
name = N_elements(name) EQ 0 ? 'C' + strtrim(index,2) : strtrim(name)
if keyword_set(alias) then begin
sz = size(alias)
if (sz[0] eq 1 || sz[0] eq 2) && (sz[1] eq 2) && (sz[sz[0]+1] eq 7) $
then begin
w = where( name eq alias[1,*], Nw)
if Nw GT 0 then name = alias[0,w[0]];
endif
endif
; Convert the string name to a valid variable name. If name
; is not defined generate the string Cnn when nn is the index
; number.
table = 0
if ~use_colnum && (N_elements(name) GT 0) then begin
if size(name,/type) eq 7 then begin
str = name[0]
endif else str = 'C'+strtrim(index,2)
endif else str = 'C'+strtrim(index,2)
return, IDL_VALIDNAME(str,/CONVERT_ALL)
end
;***************************************************************
;+
;; Parse the TFORM keyword and return the type and dimension of the
; data.
;:Private:
;-
pro eve_rwf_mrd_doff, form, dim, type
compile_opt idl2, hidden
; Find the first non-numeric character.
len = strlen(form)
if len le 0 then return
i = stregex( form, '[^0-9]') ;Position of first non-numeric character
if i lt 0 then return ;Any non-numeric character found?
if i gt 0 then begin
dim = long(strmid(form, 0, i))
if dim EQ 0l then dim = -1l
endif else dim = 0
type = strmid(form, i, 1)
end
;*********************************************************************
;+
; Check that this name is unique with regard to other column names.
;:Private:
;-
function eve_rwf_mrd_chkfn, name, namelist, index
compile_opt idl2, hidden
;
;
maxlen = 127
if strlen(name) gt maxlen then name = strmid(name, 0, maxlen)
if ~array_equal(namelist eq name,0b ) then begin
; We have found a name conflict.
;
name = 'gen$name_'+strcompress(string(index+1),/remove_all)
endif
return, name
end
;+
; Find the appropriate offset for a given unsigned type.
; The type may be given as the bitpix value or the IDL
; variable type.
;:Private:
;-
function eve_rwf_mrd_unsigned_offset, type
compile_opt idl2, hidden
if (type eq 12) || (type eq 16) then begin
return, uint(32768)
endif else if (type eq 13) || (type eq 32) then begin
return, ulong('2147483648')
endif else if (type eq 15) || (type eq 64) then begin
return, ulong64('9223372036854775808');
endif
return, 0
end
;+
; Can we treat this data as unsigned?
;:Private:
;-
function eve_rwf_mrd_chkunsigned, bitpix, scale, zero, unsigned=unsigned
compile_opt idl2, hidden
if ~keyword_set(unsigned) then return, 0
; This is correct but we should note that
; FXPAR returns a double rather than a long.
; Since the offset is a power of two
; it is an integer that is exactly representable
; as a double. However, if a user were to use
; 64 bit integers and an offset close to but not
; equal to 2^63, we would erroneously assume that
; the dataset was unsigned...
if scale eq 1 then begin
if (bitpix eq 16 && zero eq 32768L) || $
(bitpix eq 32 && zero eq 2147483648UL) || $
(bitpix eq 64 && zero eq 9223372036854775808ULL) then return,1
endif
return, 0
end
;+
; Is this one of the IDL unsigned types?
;:Private:
;-
function eve_rwf_mrd_unsignedtype, data
compile_opt idl2, hidden
type = size(data,/type)
if (type eq 12) || (type eq 13) || (type eq 15) then return, type $
else return, 0
end
;+
; Return the currrent version string for MRDFITS
;:Private:
;-
function eve_rwf_mrd_version
compile_opt idl2, hidden
return, '2.20 '
end
;=====================================================================
; END OF GENERAL UTILITY FUNCTIONS ===================================
;=====================================================================
;+
; Parse the TFORM keyword and return the type and dimension of the
; data.
;:Private:
;-
pro eve_rwf_mrd_atype, form, type, slen
compile_opt idl2, hidden
; Find the first non-numeric character.
; Get rid of blanks.
form = strcompress(form,/remove_all)
len = strlen(form)
if len le 0 then return
type = strmid(form, 0,1)
length = strmid(form,1,len-1)
;
; Ignore the number of decimal places. We assume that there
; is a decimal point.
;
p = strpos(length, '.')
if p gt 0 then length = strmid(length,0,p)
if strlen(length) gt 0 then slen = fix(length) else slen = 1
if (type EQ 'F') || (type EQ 'E') then $ ;Updated April 2007
if (slen GE 8) then type = 'D'
end
;+
; Read in the table information.
;:Private:
;-
pro eve_rwf_mrd_read_ascii, unit, range, nbytes, nrows, nfld, typarr, posarr, $
lenarr, nullarr, table, old_struct=old_struct, rows=rows
compile_opt idl2, hidden
;
; Unit Unit to read data from.
; Range Range of to be read
; Nbytes Number of bytes per row.
; Nrows Number of rows.
; Nfld Number of fields in structure.
; Typarr Array indicating type of variable.
; Posarr Starting position of fields (first char at 0)
; Lenarr Length of fields
; Nullarr Array of null values
; Table Table to read information into.
; Old_struct Should recursive structure format be used?
bigstr = bytarr(nbytes, range[1]-range[0]+1)
if range[0] gt 0 then eve_rwf_MRD_skip, unit, nbytes*range[0]
readu,unit, bigstr
if N_elements(rows) GT 0 then bigstr = bigstr[*,rows-range[0]]
; Skip to the end of the data area.
nSkipRow = nrows - range[1] - 1
nskipB = 2880 - (nbytes*nrows) mod 2880
if nskipB eq 2880 then nskipB = 0
eve_rwf_MRD_skip, unit, nskipRow*nbytes+nskipB
s1 = posarr-1
s2 = s1 + lenarr - 1
for i=0, nfld-1 do begin
flds = strtrim(bigstr[s1[i]:s2[i],* ])
if nullarr[i] ne '' then begin
curr_col = table.(i)
w = where(flds NE strtrim(nullarr[i]), Ngood)
if Ngood GT 0 then begin
if N_elements(w) EQ 1 then w = w[0]
if typarr[i] eq 'I' then begin
curr_col[w] = long(flds[w])
endif else if typarr[i] eq 'E' || typarr[i] eq 'F' then begin
curr_col[w] = float(flds[w])
endif else if typarr[i] eq 'D' then begin
curr_col[w] = double(flds[w])
endif else if typarr[i] eq 'A' then begin
curr_col[w] = flds[w]
endif
endif
table.(i) = curr_col
endif else begin
if typarr[i] eq 'I' then begin
table.(i) = long(flds)
endif else if typarr[i] eq 'E' || typarr[i] eq 'F' then begin
table.(i) = float(flds)
endif else if typarr[i] eq 'D' then begin
table.(i) = double(flds)
endif else if typarr[i] eq 'A' then begin
table.(i) = flds
endif
endelse
endfor
end
;+
; Define a structure to hold a FITS ASCII table.
;:Private:
;-
pro eve_rwf_mrd_ascii, header, structyp, use_colnum, $
range, table, $
nbytes, nrows, nfld, typarr, posarr, lenarr, nullarr, $
fnames, fvalues, scales, offsets, scaling, status, rows = rows, $
silent=silent, columns=columns, alias=alias, outalias=outalias
compile_opt idl2, hidden
;
; Header FITS header for table.
; Structyp IDL structure type to be used for
; structure.
; Use_colnum Use column numbers not names.
; Range Range of rows of interest
; Table Structure to be defined.
; Nbytes Bytes per row
; Nrows Number of rows in table
; Nfld Number of fields
; Typarr Array of field types
; Posarr Array of field offsets
; Lenarr Array of field lengths
; Nullarr Array of field null values
; Fname Column names
; Fvalues Formats for columns
; Scales/offsets Scaling factors for columns
; Scaling Do we need to scale?
; Status Return status.
table = 0
types = ['I', 'E', 'F', 'D', 'A']
; Set default 'null' values
sclstr = ['-2147483647L', '!VALUES.f_nan', '!VALUES.f_nan', '!VALUES.d_nan', '...']
status = 0
if strmid(eve_rwf_FXpar(header, 'XTENSION'),0,8) ne 'TABLE ' then begin
message, 'ERROR - Header is not from ASCII table.',/CON
status = -1;
return
endif
nfld = eve_rwf_FXpar(header, 'TFIELDS')
nrows = long64( eve_rwf_FXpar(header, 'NAXIS2'))
nbytes = long64( eve_rwf_FXpar(header, 'NAXIS1'))
if range[0] ge 0 then begin
range[0] = range[0] < (nrows-1)
range[1] = range[1] < (nrows-1)
endif else begin
range[0] = 0
range[1] = nrows-1
endelse
if N_elements(rows) EQ 0 then nrows = range[1] - range[0] + 1 else begin
bad = where(rows GT nrows, Nbad)
if Nbad GT 0 then begin
message,/CON,'ERROR: Row numbers must be between 0 and ' + $
strtrim(nrows-1,2)
status = -1
return
endif
nrows = N_elements(rows)
endelse
if nrows le 0 then begin
if ~keyword_set(silent) then begin
print,'MRDFITS: ASCII table. ',strcompress(string(nfld)), $
' columns, no rows'
endif
return
endif
;
; Loop over the columns
typarr = strarr(nfld)
lenarr = intarr(nfld)
posarr = intarr(nfld)
nullarr = strarr(nfld)
fnames = strarr(nfld)
fvalues = strarr(nfld)
scales = dblarr(nfld)
offsets = dblarr(nfld)
tname = strarr(nfld)
for i=0, nfld-1 do begin
suffix = strcompress(string(i+1), /remove_all)
fname = eve_rwf_FXpar(header, 'TTYPE' + suffix, count=cnt)
tname[i] = fname
if cnt eq 0 then xx = temporary(fname)
fform = eve_rwf_FXpar(header, 'TFORM' + suffix)
fpos = eve_rwf_FXpar(header, 'TBCOL' + suffix)
fnull = eve_rwf_FXpar(header, 'TNULL' + suffix, count=cnt)
if cnt eq 0 then fnull = ''
scales[i] = eve_rwf_FXpar(header, 'TSCAL' + suffix)
if scales[i] eq 0.0d0 then scales[i] = 1.0d0
offsets[i] = eve_rwf_FXpar(header, 'TZERO'+suffix)
fname = strupcase( eve_rwf_MRD_dofn(fname,i+1, use_colnum, alias=alias))
if i GT 0 then fname = eve_rwf_MRD_chkfn(fname, fnames, i) ;Check for duplicates
fnames[i] = fname
eve_rwf_MRD_atype, fform, ftype, flen
typarr[i] = ftype
lenarr[i] = flen
posarr[i] = fpos
nullarr[i] = fnull
j = where(types EQ ftype, Nj)
if Nj EQ 0 then begin
message, 'Invalid format code:'+ ftype + ' for column ' + $
strtrim(i+1,2),/CON
status = -1
return
endif
fvalues[i] = ftype NE 'A' ? sclstr[j] : $
'string(replicate(32b,'+strtrim(flen,2)+'))'
endfor
if scaling then $
scaling = ~array_equal(scales,1.0d0) || ~array_equal(offsets,0.0)
if ~scaling && ~keyword_set(columns) then begin
table = eve_rwf_MRD_struct(fnames, fvalues, nrows, structyp=structyp, $
silent=silent)
endif else begin
table = eve_rwf_MRD_struct(fnames, fvalues, nrows, silent=silent)
endelse
if ~keyword_set(silent) then begin
print,'MRDFITS: ASCII table. ',strcompress(string(nfld)), $
' columns by ',strcompress(string(nrows)), ' rows.'
endif
outalias = transpose([ [tag_names(table)],[tname] ] )
status = 0
return
end
;+
; Eliminate columns from the table that do not match the
; user specification.
;:Private:
;-
pro eve_rwf_mrd_columns, table, columns, fnames, fvalues, $
vcls, vtpes, scales, offsets, scaling, $
structyp=structyp, silent=silent
compile_opt idl2, hidden
type = size(columns,/type)
nele = N_elements(columns)
if type eq 8 || type eq 6 || type eq 0 then return ; Can't use structs
; or complex.
if type eq 4 || type eq 5 then tcols = fix(columns)
if type eq 1 || type eq 2 || type eq 3 then tcols = columns
; Convert strings to uppercase and compare with column names.
if type eq 7 then begin
eve_rwf_match, strupcase(columns), strupcase(fnames), tmp, tcols,count=nmatch
if Nmatch GT 0 then begin
s = sort(tmp) ;Sort order of supplied column name
tcols = tcols[s] + 1
endif
endif
; Subtract one from column indices and check that all indices >= 0.
if n_elements(tcols) gt 0 then begin
tcols = tcols-1
w = where(tcols ge 0, Nw)
if Nw EQ 0 then dummy = temporary(tcols)
endif
if n_elements(tcols) le 0 then begin
print, 'MRDFITS: No columns match'
; Undefine variables. First ensure they are defined, then
; use temporary() to undefine them.
table = 0
fnames = 0
fvalues = 0
vcls = 0
vtpes = 0
scales = 0
offsets = 0
dummy = temporary(fnames)
dummy = temporary(fvalues)
dummy = temporary(vcls)
dummy = temporary(vtpes)
dummy = temporary(scales)
dummy = temporary(offsets)
scaling = 0
endif else begin
; Replace arrays with only desired columns.
fnames = fnames[tcols]
fvalues = fvalues[tcols]
; Check if there are still variable length columns.
if n_elements(vcls) gt 0 then begin
vcls = vcls[tcols]
vtpes = vtpes[tcols]
w = where(vcls eq 1, Nw)
if Nw EQ 0 then begin
dummy = temporary(vcls)
dummy = temporary(vtpes)
endif
endif
; Check if there are still columns that need scaling.
if n_elements(scales) gt 0 then begin
scales = scales[tcols]
offsets = offsets[tcols]
scaling = ~array_equal(scales,1.d0) || ~array_equal(offsets,0.0)
endif
ndim = n_elements(table)
if scaling || n_elements(vcls) gt 0 then begin
tabx = eve_rwf_MRD_struct(fnames, fvalues, ndim, silent=silent )
endif else begin
tabx = eve_rwf_MRD_struct(fnames, fvalues, ndim, structyp=structyp, silent=silent )
endelse
for i=0, n_elements(tcols)-1 do $
tabx.(i) = table.(tcols[i]);
table = temporary(tabx)
endelse
end
;+
; Read in the image information.
;:Private:
;-
pro eve_rwf_mrd_read_image, unit, range, maxd, rsize, table, rows = rows,status=status, $
unixpipe = unixpipe
compile_opt idl2, hidden
;
; Unit Unit to read data from.
; Table Table/array to read information into.
;
error=0
catch,error
if error ne 0 then begin
catch,/cancel
status=-2
return
endif
; If necessary skip to beginning of desired data.
if range[0] gt 0 then eve_rwf_MRD_skip, unit, range[0]*rsize
status=-2
if rsize eq 0 then return
on_ioerror,done
readu, unit, table
if N_elements(rows) GT 0 then begin
row1 = rows- range[0]
case size(table,/n_dimen) of
1: table = table[row1]
2: table = table[*,row1]
3: table = table[*,*,row1]
4: table = table[*,*,*,row1]
5: table = table[*,*,*,*,row1]
6: table = table[*,*,*,*,*,row1]
7: table = table[*,*,*,*,*,*,row1]
8: table = table[*,*,*,*,*,*,*,row1]
else: begin
print,'MRDFITS: Subscripted image must be between 1 and 8 dimensions'
status = -1
return
end
endcase
endif
; Skip to the end of the data
skipB = 2880 - (maxd*rsize) mod 2880
if skipB eq 2880 then skipB = 0
if range[1] lt maxd-1 then $
skipB = skipB + (maxd-range[1]-1)*rsize
eve_rwf_MRD_skip, unit, skipB
if unixpipe then swap_endian_inplace, table,/swap_if_little
; Fix offset for unsigned data
type = eve_rwf_MRD_unsignedtype(table)
if type gt 0 then $
table = table - eve_rwf_MRD_unsigned_offset(type)
status=0
done:
;-- probably an EOF
if status ne 0 then begin
message,!ERROR_STATE.MSG,/CON
free_lun,unit
endif
return
end
;+
; Truncate superfluous axes.
;:Private:
;-
pro eve_rwf_mrd_axes_trunc,naxis, dims, silent
compile_opt idl2, hidden
mysilent = silent
for i=naxis-1,1,-1 do begin
if dims[i] eq 1 then begin
if ~mysilent then begin
print, 'MRDFITS: Truncating unused dimensions'
mysilent = 1
endif
dims = dims[0:i-1]
naxis = naxis - 1
endif else return
endfor
return
end
;+
; Define structure/array to hold a FITS image.
;:Private:
;-
pro eve_rwf_mrd_image, header, range, maxd, rsize, table, scales, offsets, scaling, $
status, silent=silent, unsigned=unsigned, rows = rows
compile_opt idl2, hidden
;
; Header FITS header for table.
; Range Range of data to be retrieved.
; Rsize Size of a row or group.
; Table Structure to be defined.
; Status Return status
; Silent=silent Suppress info messages?
table = 0
; type 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
lens = [ 0, 1, 2, 4, 4, 8, 0, 0, 0, 0, 0, 0, 2, 4, 8, 8]
typstrs=['', 'Byte', 'Int*2', 'Int*4', 'Real*4', 'Real*8','','','','','','', 'UInt*2', 'Uint*4', 'Int*8', 'Uint*8']
typarr= ['', 'bytarr', 'intarr', 'lonarr', 'fltarr', 'dblarr','','','','','','','uintarr', 'ulonarr', 'lon64arr', 'ulon64arr']
status = 0
naxis = eve_rwf_FXpar(header, 'NAXIS')
bitpix= eve_rwf_FXpar(header, 'BITPIX')
if naxis gt 0 then begin
dims = long64(eve_rwf_FXpar(header, 'NAXIS*', Count = N_axis))
if N_axis GT naxis then begin
; Check if extra NAXISn keywords are present (though this is not legal FITS)
nextra = N_axis - naxis
dim_extra = dims[naxis:N_axis-1]
if total(dim_extra) EQ nextra then $
dims = dims[0:naxis-1] else $
message,'ERROR - NAXIS = ' + strtrim(naxis,2) + $
' but NAXIS' + strtrim(N_axis,2) + ' keyword present'
endif
endif else dims = 0
gcount = eve_rwf_FXpar(header, 'GCOUNT')
pcount = eve_rwf_FXpar(header, 'PCOUNT')
isgroup = eve_rwf_FXpar(header, 'GROUPS')
gcount = long(gcount)
xscale = eve_rwf_FXpar(header, 'BSCALE', count=cnt)
if cnt eq 0 then xscale = 1 ;Corrected 06/29/06
xunsigned = eve_rwf_MRD_chkunsigned(bitpix, xscale, $
eve_rwf_FXpar(header, 'BZERO'), unsigned=unsigned)
; Note that type is one less than the type signifier returned in the size call.
type = -1
if ~xunsigned then begin
if bitpix eq 8 then type = 1 $
else if bitpix eq 16 then type = 2 $
else if bitpix eq 32 then type = 3 $
else if bitpix eq -32 then type = 4 $
else if bitpix eq -64 then type = 5 $
else if bitpix eq 64 then type = 14
endif else begin
if bitpix eq 16 then type = 12 $
else if bitpix eq 32 then type = 13 $
else if bitpix eq 64 then type = 15
endelse
if type eq -1 then begin
print,'MRDFITS: Error: Invalid BITPIX: '+strtrim(bitpix)
table = 0
return
endif
; Note that for random groups data we must ignore the first NAXISn keyword.
if isgroup GT 0 then begin
range[0] = range[0] > 0
if (range[1] eq -1) then begin
range[1] = gcount-1
endif else begin
range[1] = range[1] < gcount - 1
endelse
maxd = gcount
if (n_elements(dims) gt 1) then begin
dims = dims[1:*]
naxis = naxis-1
endif else begin
print, 'MRDFITS: Warning: No data specified for group data.'
dims = [0]
naxis = 0
endelse
; The last entry is the scaling for the sample data.
if (pcount gt 0) then begin
scales = dblarr(pcount+1)
offsets = dblarr(pcount+1)
endif
values = strarr(2)
eve_rwf_MRD_axes_trunc, naxis, dims, keyword_set(silent)
values[0] = typarr[type] + "("+string(pcount)+")"
rsize = dims[0]
sarr = "(" + strcompress(string(dims[0]), /remo )
for i=1, naxis-1 do begin
sarr = sarr + "," + strcompress(string(dims[i]),/remo)
rsize = rsize*dims[i]
endfor
sarr = sarr + ")"
if ~keyword_set(silent) then print,'MRDFITS--Image with groups:', $
' Ngroup=',strcompress(string(gcount)),' Npar=', $
strcompress(string(pcount),/remo), ' Group=', sarr, ' Type=',typstrs[type]
sarr = typarr[type] + sarr
values[1] = sarr
rsize = (rsize + pcount)*lens[type]
table = eve_rwf_MRD_struct(['params','array'], values, range[1]-range[0]+1, $
silent=silent)
if xunsigned then begin
eve_rwf_fxaddpar,header, 'BZERO', 0, 'Reset by MRDFITS v'+eve_rwf_MRD_version()
endif
for i=0, pcount-1 do begin
istr = strcompress(string(i+1),/remo)
scales[i] = eve_rwf_FXpar(header, 'PSCAL'+istr)
if scales[i] eq 0.0d0 then scales[i] =1.0d0
offsets[i] = eve_rwf_FXpar(header, 'PZERO'+istr)
scales[pcount] = eve_rwf_FXpar(header, 'BSCALE')
if scales[pcount] eq 0.0d0 then scales[pcount] = 1.0d0
offsets[pcount] = eve_rwf_FXpar(header, 'BZERO')
endfor
if scaling then $
scaling = ~array_equal(scales,1.0d0) || ~array_equal(offsets,0.0)
endif else begin
if naxis eq 0 then begin
rsize = 0
table = 0
if ~keyword_set(silent) then $
print, 'MRDFITS: Null image, NAXIS=0'
return
endif
if gcount gt 1 then begin
dims = [dims, gcount]
naxis = naxis + 1
endif
eve_rwf_MRD_axes_trunc, naxis, dims, keyword_set(silent)
maxd = dims[naxis-1]
if range[0] ne -1 then begin
range[0] = range[0]<(maxd-1)
range[1] = range[1]<(maxd-1)
endif else begin
range[0] = 0
range[1] = maxd - 1
endelse
Nlast = dims[naxis-1]
dims[naxis-1] = range[1]-range[0]+1
pdims = dims
if N_elements(rows) GT 0 then begin
if max(rows) GE Nlast then begin
print, 'MRDFITS: Row numbers must be between 0 and ' + $
strtrim(Nlast-1,2)
status = -1 & rsize = 0
return
endif
pdims[naxis-1] = N_elements(rows)
endif
if ~keyword_set(silent) then begin
str = '('
for i=0, naxis-1 do begin
if i ne 0 then str = str + ','
str = str + strcompress(string(pdims[i]),/remo)
endfor
str = str+')'
print, 'MRDFITS: Image array ',str, ' Type=', typstrs[type]
endif
rsize = 1
if naxis gt 1 then for i=0, naxis - 2 do rsize=rsize*dims[i]
rsize = rsize*lens[type]
sz = lonarr(naxis+3)
sz[0] = naxis
sz[1:naxis] = dims
nele = product(dims,/integer)
sz[naxis+1] = type
sz[naxis+2] = nele
table = nele GT 0 ? make_array(size=sz) : 0
scales = dblarr(1)
offsets = dblarr(1)
if xunsigned then begin
eve_rwf_fxaddpar,header, 'BZERO', 0, 'Updated by MRDFITS v'+eve_rwf_MRD_version()
endif
scales[0] = eve_rwf_FXpar(header, 'BSCALE')
offsets[0] = eve_rwf_FXpar(header, 'BZERO')
if scales[0] eq 0.0d0 then scales[0] = 1.0d0
if scaling && (scales[0] eq 1.0d0) && (offsets[0] eq 0.0d0) then $
scaling = 0
endelse
status = 0
return
end
;+
; Scale an array of pointers
;:Private:
;-
pro eve_rwf_mrd_ptrscale, array, scale, offset
compile_opt idl2, hidden
for i=0, n_elements(array)-1 do begin
if ptr_valid(array[i]) then begin
array[i] = ptr_new(*array[i] * scale + offset)
endif
endfor
end
;+
;; Scale a FITS array or table.
;:Private:
;-
pro eve_rwf_mrd_string, table, header, typarr, $
fnames, fvalues, nrec, structyp=structyp, silent=silent
compile_opt idl2, hidden
;
; Type: FITS file type, 0=image/primary array
; 1=ASCII table
; 2=Binary table
;
; scales: An array of scaling info
; offsets: An array of offset information
; table: The FITS data.
; header: The FITS header.
; dscale: Should data be scaled to R*8?
; fnames: Names of table columns.
; fvalues: Values of table columns.
; nrec: Number of records used.
; structyp: Structure name.
w = where( typarr EQ 'A', Nw, $
complement=ww, Ncomplement = Nww)
if Nw EQ 0 then return ;No tags require string conversion?
; First do ASCII and Binary tables. We need to create a new structure
; because scaling will change the tag data types.
sclr = "' '"
vc = 'strarr'
for i=0, Nw-1 do begin
col = w[i]
sz = size(table[0].(col),/str)
; Handle pointer columns
if sz.type eq 10 then begin
fvalues[col] = 'ptr_new()'
; Scalar columns
endif else if sz.N_dimensions eq 0 then begin
fvalues[col] = sclr
; Vectors
endif else begin
dim = sz.dimensions[0:sz.N_dimensions-1]
fvalues[col] = vc + $
'(' + strjoin(strtrim(dim,2),',') + ')'
endelse
endfor
tabx = eve_rwf_MRD_struct(fnames, fvalues, nrec, structyp=structyp, silent=silent )
; First copy the unscaled columns indexed by ww. This is actually more
; efficient than using STRUCT_ASSIGN since the tag names are all identical,
; so STRUCT_ASSIGN would copy everything (scaled and unscaled).
for i=0, Nww - 1 do tabx.(ww[i]) = table.(ww[i])
; Now copy the string items indexed by w after converting the byte array
for i=0, Nw - 1 do begin
str = size(tabx.(w[i]),/str)
dim = [1,str.dimensions[0:str.N_dimensions-1]]
if str.n_dimensions GT 1 then $
tabx.(w[i]) = string(reform(table.(w[i]),dim)) else $
tabx.(w[i]) = string(table.(w[i]))
endfor
table = temporary(tabx) ;Remove original structure from memory
end
;+
;; Scale a FITS array or table.
;:Private:
;-
pro eve_rwf_mrd_scale, type, scales, offsets, table, header, $
fnames, fvalues, nrec, dscale = dscale, structyp=structyp, silent=silent
compile_opt idl2, hidden
;
; Type: FITS file type, 0=image/primary array
; 1=ASCII table
; 2=Binary table
;
; scales: An array of scaling info
; offsets: An array of offset information
; table: The FITS data.
; header: The FITS header.
; dscale: Should data be scaled to R*8?
; fnames: Names of table columns.
; fvalues: Values of table columns.
; nrec: Number of records used.
; structyp: Structure name.
w = where( (scales ne 1.d0 || offsets ne 0.d0), Nw, $
complement=ww, Ncomplement = Nww)
if Nw EQ 0 then return ;No tags require scaling?
; First do ASCII and Binary tables. We need to create a new structure
; because scaling will change the tag data types.
if type ne 0 then begin
if type eq 1 then begin
fvalues[w] = keyword_set(dscale) ? '0.0d0' : '0.0
endif else if type eq 2 then begin
if keyword_set(dscale) then begin
sclr = '0.d0'
vc = 'dblarr'
endif else begin
sclr = '0.0'
vc = 'fltarr'
endelse
for i=0, Nw-1 do begin
col = w[i]
sz = size(table[0].(col),/str)
; Handle pointer columns
if sz.type eq 10 then begin
fvalues[col] = 'ptr_new()'
; Scalar columns
endif else if sz.N_dimensions eq 0 then begin
fvalues[col] = sclr
; Vectors
endif else begin
dim = sz.dimensions[0:sz.N_dimensions-1]
fvalues[col] = vc + $
'(' + strjoin(strtrim(dim,2),',') + ')'
endelse
endfor
endif
tabx = eve_rwf_MRD_struct(fnames, fvalues, nrec, structyp=structyp, silent=silent )
; First copy the unscaled columns indexed by ww. This is actually more
; efficient than using STRUCT_ASSIGN since the tag names are all identical,
; so STRUCT_ASSIGN would copy everything (scaled and unscaled).
for i=0, Nww - 1 do tabx.(ww[i]) = table.(ww[i])
; Now copy the scaled items indexed by w after applying the scaling.
for i=0, Nw - 1 do begin
dtype = size(tabx.(w[i]),/type)
if dtype eq 10 then $
eve_rwf_MRD_ptrscale, table.(w[i]), scales[w[i]], offsets[w[i]]
tabx.(w[i]) = table.(w[i])*scales[w[i]] + offsets[w[i]]
istr = strtrim(w[i]+1,2)
eve_rwf_fxaddpar, header, 'TSCAL'+istr, 1.0, ' Set by MRD_SCALE'
eve_rwf_fxaddpar, header, 'TZERO'+istr, 0.0, ' Set by MRD_SCALE'
endfor
table = temporary(tabx) ;Remove original structure from memory
endif else begin
; Now process images and random groups.
sz = size(table[0])
if sz[sz[0]+1] ne 8 then begin
; Not a structure so we just have an array of data.
if keyword_set(dscale) then begin
table = temporary(table)*scales[0]+offsets[0]
endif else begin
table = temporary(table)*float(scales[0]) + float(offsets[0])
endelse
eve_rwf_fxaddpar, header, 'BSCALE', 1.0, 'Set by MRD_SCALE'
eve_rwf_fxaddpar, header, 'BZERO', 0.0, 'Set by MRD_SCALE'
endif else begin
; Random groups. Get the number of parameters by looking
; at the first element in the table.
nparam = n_elements(table[0].(0))
if keyword_set(dscale) then typ = 'dbl' else typ='flt'
s1 = typ+'arr('+string(nparam)+')'
ngr = n_elements(table)
sz = size(table[0].(1))
if sz[0] eq 0 then dims = [1] else dims=sz[1:sz[0]]
s2 = typ + 'arr('
for i=0, n_elements(dims)-1 do begin
if i ne 0 then s2 = s2+ ','
s2 = s2+string(dims[i])
endfor
s2 = s2+')'
tabx = eve_rwf_MRD_struct(['params', 'array'],[s1,s2],ngr, silent=silent)
for i=0, nparam-1 do begin
istr = strcompress(string(i+1),/remo)
eve_rwf_fxaddpar, header, 'PSCAL'+istr, 1.0, 'Added by MRD_SCALE'
eve_rwf_fxaddpar, header, 'PZERO'+istr, 0.0, 'Added by MRD_SCALE'
tabx.(0)[i] = table.(0)[i]*scales[i]+offsets[i]
endfor
tabx.(1) = table.(1)*scales[nparam] + offsets[nparam]
eve_rwf_fxaddpar, header, 'BSCALE', 1.0, 'Added by MRD_SCALE'
eve_rwf_fxaddpar, header, 'BZERO', 0.0, 'Added by MRD_SCALE'
table = temporary(tabx)
endelse
endelse
end
;+
; Read a variable length column into a pointer array.
;:Private:
;-
pro eve_rwf_mrd_varcolumn, vtype, array, heap, off, siz
compile_opt idl2, hidden
; Guaranteed to have at least one non-zero length column
w = where(siz gt 0)
nw = n_elements(w)
if vtype eq 'X' then siz = 1 + (siz-1)/8
siz = siz[w]
off = off[w]
unsigned = 0
if vtype eq '1' then begin
unsigned = 12
endif else if vtype eq '2' then begin
unsigned = 13
endif else if vtype eq '3' then begin
unsigned = 15;
endif
unsigned = eve_rwf_MRD_unsigned_offset(unsigned)
for j=0, nw-1 do begin
case vtype of
'L': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) )
'X': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) )
'B': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) )
'I': array[w[j]] = ptr_new( fix(heap, off[j], siz[j]) )
'J': array[w[j]] = ptr_new( long(heap, off[j], siz[j]) )
'K': array[w[j]] = ptr_new( long64(heap, off[j], siz[j]) )
'E': array[w[j]] = ptr_new( float(heap, off[j], siz[j]) )
'D': array[w[j]] = ptr_new( double(heap, off[j], siz[j]) )
'C': array[w[j]] = ptr_new( complex(heap, off[j], siz[j]) )
'M': array[w[j]] = ptr_new( dcomplex(heap, off[j], siz[j]) )
'1': array[w[j]] = ptr_new( uint(heap, off[j], siz[j]) )
'2': array[w[j]] = ptr_new( ulong(heap, off[j], siz[j]) )
'3': array[w[j]] = ptr_new( ulong64(heap, off[j], siz[j]) )
endcase
; Fix endianness.
if (vtype ne 'B') && (vtype ne 'X') && (vtype ne 'L') then begin
swap_endian_inplace, *array[w[j]],/swap_if_little
endif
; Scale unsigneds.
if unsigned gt 0 then *array[w[j]] = *array[w[j]] - unsigned
endfor
end
;+
; Read a variable length column into a fixed length array.
;:Private:
;-
pro eve_rwf_mrd_fixcolumn, vtype, array, heap, off, siz
compile_opt idl2, hidden
w = where(siz gt 0, nw)
if nw EQ 0 then return
if vtype eq 'X' then siz = 1 + (siz-1)/8
siz = siz[w]
off = off[w]
for j=0, nw-1 do begin
case vtype of
'L': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j])
'X': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j])
'B': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j])
'I': array[0:siz[j]-1,w[j]] = fix(heap, off[j], siz[j])
'J': array[0:siz[j]-1,w[j]] = long(heap, off[j], siz[j])
'K': array[0:siz[j]-1,w[j]] = long64(heap, off[j], siz[j])
'E': begin ;Delay conversion until after byteswapping to avoid possible math overflow Feb 2005
temp = heap[off[j]: off[j] + 4*siz[j]-1 ]
byteorder, temp, /LSWAP, /SWAP_IF_LITTLE
array[0:siz[j]-1,w[j]] = float(temp,0,siz[j])
end
'D': begin
temp = heap[off[j]: off[j] + 8*siz[j]-1 ]
byteorder, temp, /L64SWAP, /SWAP_IF_LITTLE
array[0:siz[j]-1,w[j]] = double(temp,0,siz[j])
end
'C': array[0:siz[j]-1,w[j]] = complex(heap, off[j], siz[j])
'M': array[0:siz[j]-1,w[j]] = dcomplex(heap, off[j], siz[j])
'A': array[w[j]] = string(byte(heap,off[j],siz[j]))
'1': array[0:siz[j]-1,w[j]] = uint(heap, off[j], siz[j])
'2': array[0:siz[j]-1,w[j]] = ulong(heap, off[j], siz[j])
'3': array[0:siz[j]-1,w[j]] = ulong64(heap, off[j], siz[j])
endcase
endfor
; Fix endianness for datatypes with more than 1 byte
if ~stregex(vtype,'[^ABXLDE]') then $
swap_endian_inplace, array, /swap_if_little
; Scale unsigned data
case vtype of
'1': unsigned = 12
'2': unsigned = 13
'3': unsigned = 15
else: unsigned = 0
endcase
if unsigned gt 0 then $
unsigned = eve_rwf_MRD_unsigned_offset(unsigned)
if unsigned gt 0 then begin
for j=0, nw-1 do begin
array[0:siz[j]-1,w[j]] = array[0:siz[j]-1,w[j]] - unsigned
endfor
endif
end
;+
; Read the heap area to get the actual values of variable
; length arrays.
;:Private:
;-
pro eve_rwf_mrd_read_heap, unit, header, range, fnames, fvalues, vcls, vtpes, table, $
structyp, scaling, scales, offsets, status, silent=silent, $
columns=columns, rows = rows, pointer_var=pointer_var, fixed_var=fixed_var
compile_opt idl2, hidden
;
; Unit: FITS unit number.
; header: FITS header.
; fnames: Column names.
; fvalues: Column values.
; vcols: Column numbers of variable length columns.
; vtypes: Actual types of variable length columns
; table: Table of data from standard data area, on output
; contains the variable length data.
; structyp: Structure name.
; scaling: Is there going to be scaling of the data?
; status: Set to -1 if an error occurs.
;
typstr = 'LXBIJKAEDCM123'
prefix = ['bytarr(', 'bytarr(', 'bytarr(', 'intarr(', $
'lonarr(', 'lon64arr(', 'string(bytarr(', 'fltarr(', $
'dblarr(', 'complexarr(', 'dcomplexarr(', $
'uintarr(', 'ulonarr(', 'ulon64arr(']
status = 0
; Convert from a list of indicators of whether a column is variable
; length to pointers to only the variable columns.
vcols = where(vcls eq 1)
vtypes = vtpes[vcols]
nv = n_elements(vcols)
; Find the beginning of the heap area.
heapoff = long64(eve_rwf_FXpar(header, 'THEAP'))
sz = eve_rwf_FXpar(header, 'NAXIS1')*eve_rwf_FXpar(header, 'NAXIS2')
if (heapoff ne 0) && (heapoff lt sz) then begin
print, 'MRDFITS: ERROR Heap begins within data area'
status = -1
return
endif
; Skip to beginning.
if (heapoff > sz) then begin
eve_rwf_MRD_skip, unit, heapoff-sz
endif
; Get the size of the heap.
pc = long64(eve_rwf_FXpar(header, 'PCOUNT'))
if heapoff eq 0 then heapoff = sz
hpsiz = pc - (heapoff-sz)
if (hpsiz gt 0) then heap = bytarr(hpsiz)
; Read in the heap
readu, unit, heap
; Skip to the end of the data area.
skipB = 2880 - (sz+pc) mod 2880
if skipB ne 2880 then begin
eve_rwf_MRD_skip, unit, skipB
endif
; Find the maximum dimensions of the arrays.
;
; Note that the variable length column currently has fields which
; are I*4 2-element arrays where the first element is the
; length of the field on the current row and the second is the
; offset into the heap.
vdims = lonarr(nv)
for i=0, nv-1 do begin
col = vcols[i]
curr_col = table.(col)
vdims[i] = max(curr_col[0,*])
w = where(curr_col[0,*] ne vdims[i])
if w[0] ne -1 then begin
if n_elements(lencols) eq 0 then begin
lencols = [col]
endif else begin
lencols=[lencols,col]
endelse
endif
if vtypes[i] eq 'X' then vdims[i]=(vdims[i]+7)/8
ind = strpos(typstr, vtypes[i])
; Note in the following that we ensure that the array is
; at least one element long.
fvalues[col] = prefix[ind] + string((vdims[i] > 1)) + ')'
if vtypes[i] eq 'A' then fvalues[col] = fvalues[col] + ')'
endfor
nfld = n_elements(fnames)
; Get rid of columns which have no actual data.
w= intarr(nfld)
w[*] = 1
corres = indgen(nfld)
; Should we get rid of empty columns?
delete = 1
if keyword_set(pointer_var) then delete = pointer_var eq 1
if delete then begin
ww = where(vdims eq 0, N_ww)
if N_ww GT 0 then begin
w[vcols[ww]] = 0
if ~keyword_set(silent) then $
print, 'MRDFITS: ', strcompress(string(n_elements(ww))), $
' unused variable length columns deleted'
endif
; Check if all columns have been deleted...
wx = where(w gt 0, N_wx)
if N_wx EQ 0 then begin
if ~keyword_set(silent) then $
print, 'MRDFITS: All columns have been deleted'
table = 0
return
endif
; Get rid of unused columns.
corres = corres[wx]
fnames = fnames[wx]
fvalues = fvalues[wx]
scales = scales[wx]
offsets = offsets[wx]
wx = where(vdims gt 0)
if (wx[0] eq -1) then begin
vcols=[-9999]
x=temporary(vtypes)
x=temporary(vdims)
endif else begin
vcols = vcols[wx]
vtypes = vtypes[wx]
vdims = vdims[wx]
endelse
endif
if ~keyword_set(pointer_var) then begin
; Now add columns for lengths of truly variable length records.
if n_elements(lencols) gt 0 then begin
if ~keyword_set(silent) then $
print, 'MRDFITS: ', strcompress(string(n_elements(lencols))), $
' length column[s] added'
for i=0, n_elements(lencols)-1 do begin
col = lencols[i]
w = where(col eq corres)
ww = where(col eq vcols)
w = w[0]
ww = ww[0]
fvstr = '0L' ; <-- Originally, '0l'; breaks under the virtual machine!
fnstr = 'L'+strcompress(string(col),/remo)+'_'+fnames[w]
nf = n_elements(fnames)
; Note that lencols and col refer to the index of the
; column before we started adding in the length
; columns.
if w eq nf-1 then begin
; Subtract -1 for the length columns so 0 -> -1 and
; we can distinguish this column.
corres = [corres, -col-1 ]
fnames = [fnames, fnstr ]
fvalues = [fvalues, fvstr ]
scales = [scales, 1.0d0 ]
offsets = [offsets, 0.0d0 ]
endif else begin
corres = [corres[0:w],-col-1,corres[w+1:nf-1] ]
fnames = [fnames[0:w],fnstr,fnames[w+1:nf-1] ]
fvalues = [fvalues[0:w],fvstr,fvalues[w+1:nf-1] ]
scales = [scales[0:w], 1.0d0, scales[w+1:nf-1] ]
offsets = [offsets[0:w],0.0d0, offsets[w+1:nf-1] ]
endelse
endfor
endif
endif else begin
; We'll just read data into pointer arrays.
for i=0,n_elements(lencols)-1 do begin
col = lencols[i]
if vtpes[col] eq 'A' then begin
fvalues[col] = '" "'
endif else begin
fvalues[col] = 'ptr_new()'
endelse
endfor
endelse
; Generate a new table with the appropriate structure definitions
if ~scaling && ~keyword_set(columns) then begin
tablex = eve_rwf_MRD_struct(fnames, fvalues, n_elements(table), structyp=structyp, $
silent=silent)
endif else begin
tablex = eve_rwf_MRD_struct(fnames, fvalues, n_elements(table), silent=silent)
endelse
if N_elements(rows) EQ 0 then nrow = range[1]-range[0]+1 $
else nrow = N_elements(rows)
; I loops over the new table columns, col loops over the old table.
; When col is negative, it is a length column.
for i=0, n_elements(fnames)-1 do begin
col = corres[i]
if col ge 0 then begin
w = where(vcols eq col)
; First handle the case of a column that is not
; variable length -- just copy the column.
if w[0] eq -1 then begin
tablex.(i) = table.(col)
endif else begin
vc = w[0]
; Now handle the variable length columns
; If only one row in table, then
; IDL will return curr_col as one-dimensional.
; Since this is a variable length pointer column we
; know that the dimension of the column is 2.
curr_col = table.(col)
if (nrow eq 1) then curr_col = reform(curr_col,2,1)
siz = curr_col[0,*]
off = curr_col[1,*]
; Now process each type.
curr_colx = tablex.(i)
sz = size(curr_colx)
if (sz[0] lt 2) then begin
curr_colx = reform(curr_colx, 1, n_elements(curr_colx), /overwrite)
endif
; As above we have to worry about IDL truncating
; dimensions. This can happen if either
; nrow=1 or the max dimension of the column is 1.
sz = size(tablex.(i))
nel = sz[sz[0]+2]
if (nrow eq 1) && (nel eq 1) then begin
curr_colx = make_array(1,1,value=curr_colx)
endif else if nrow eq 1 then begin
curr_colx = reform(curr_colx,[nel, 1], /overwrite)
endif else if nel eq 1 then begin
curr_colx = reform(curr_colx,[1, nrow], /overwrite)
endif
vtype = vtypes[vc]
varying = 0
if n_elements(lencols) gt 0 then begin
varying = where(lencols eq col)
if varying[0] eq -1 then varying=0 else varying=1
endif
if varying && keyword_set(pointer_var) && (vtype ne 'A') then begin
eve_rwf_MRD_varcolumn, vtype, curr_colx, heap, off, siz
endif else begin
eve_rwf_MRD_fixcolumn, vtype, curr_colx, heap, off, siz
endelse
if nel eq 1 and nrow eq 1 then begin
curr_colx = curr_colx[0]
endif else if nrow eq 1 then begin
curr_colx = reform(curr_colx, nel, /overwrite)
endif else if nel eq 1 then begin
curr_colx = reform(curr_colx, nrow, /overwrite)
endif
sz = size(curr_colx)
if sz[1] eq 1 then begin
sz_tablex = size(tablex.(i))
sdimen = sz_tablex[1:sz_tablex[0]]
tablex.(i) = reform(curr_colx,sdimen)
endif else begin
tablex.(i) = curr_colx
endelse
endelse
endif else begin
; Now handle the added columns which hold the lengths
; of the variable length columns.
ncol = -col - 1 ; Remember we subtracted an extra one.
xx = table.(ncol)
tablex.(i) = reform(xx[0,*])
endelse
endfor
; Finally get rid of the initial table and return the table with the
; variable arrays read in.
;
table = temporary(tablex)
return
end
;+
; Read in the binary table information.
;:Private:
;-
pro eve_rwf_mrd_read_table, unit, range, rsize, structyp, nrows, nfld, typarr, table, rows = rows, $
unixpipe = unixpipe
compile_opt idl2, hidden
;
;
; Unit Unit to read data from.
; Range Desired range
; Rsize Size of row.
; structyp Structure type.
; Nfld Number of fields in structure.
; Typarr Field types
; Table Table to read information into.
;
if range[0] gt 0 then eve_rwf_MRD_skip, unit, rsize*range[0]
readu,unit, table
if N_elements(rows) GT 0 then table = table[rows- range[0]]
; Move to the beginning of the heap -- we may have only read some rows of
; the data.
if range[1] lt nrows-1 then begin
skip_dist = (nrows-range[1]-1)*rsize
eve_rwf_MRD_skip, unit, skip_dist
endif
; If necessary then convert to native format.
if unixpipe then swap_endian_inplace,table,/swap_if_little
; Handle unsigned fields.
for i=0, nfld-1 do begin
type = eve_rwf_MRD_unsignedtype(table.(i))
if type gt 0 then begin
table.(i) = table.(i) - eve_rwf_MRD_unsigned_offset(type)
endif
endfor
end
;+
; Check the values of TDIM keywords to see that they have valid
; dimensionalities. If the TDIM keyword is not present or valid
; then the a one-dimensional array with a size given in the TFORM
; keyword is used.
;:Private:
;-
pro eve_rwf_mrd_tdim, header, index, flen, arrstr, no_tdim=no_tdim
compile_opt idl2, hidden
; HEADER Current header array.
; Index Index of current parameter
; flen Len given in TFORM keyword
; arrstr String returned to be included within paren's in definition.
; no_tdim Disable TDIM processing
arrstr = strcompress(string(flen),/remo)
if keyword_set(no_tdim) then return
tdstr = eve_rwf_FXpar(header, 'TDIM'+strcompress(string(index),/remo))
if tdstr eq '' then return
;
; Parse the string. It should be of the form '(n1,n2,...nx)' where
; all of the n's are positive integers and the product equals flen.
;
tdstr = strcompress(tdstr,/remo)
len = strlen(tdstr)
if strmid(tdstr,0,1) ne '(' && strmid(tdstr,len-1,1) ne ')' || len lt 3 then begin
print, 'MRDFITS: Error: invalid TDIM for column', index
return
endif
; Get rid of parens.
tdstr = strmid(tdstr,1,len-2)
len = len-2
nind = 0
cnum = 0
for nchr=0, len-1 do begin
c = strmid(tdstr,nchr, 1)
if c ge '0' && c le '9' then begin
cnum = 10*cnum + long(c)
endif else if c eq ',' then begin
if cnum le 0 then begin
print,'MRDFITS: Error: invalid TDIM for column', index
return
endif
if n_elements(numbs) eq 0 then $
numbs = cnum $
else numbs = [numbs,cnum]
cnum = 0
endif else begin
print,'MRDFITS: Error: invalid TDIM for column', index
return
endelse
endfor
; Handle the last number.
if cnum le 0 then begin
print,'MRDFITS: Error: invalid TDIM for column', index
return
endif
if n_elements(numbs) eq 0 then numbs = cnum else numbs = [numbs,cnum]
prod = 1
for i=0, n_elements(numbs)-1 do prod = prod*numbs[i]
if prod ne flen then begin
print,'MRDFITS: Error: TDIM/TFORM dimension mismatch'
return
endif
arrstr = tdstr
end
;+
; Define a structure to hold a FITS binary table.
;:Private:
;-
pro eve_rwf_mrd_table, header, structyp, use_colnum, $
range, rsize, table, nrows, nfld, typarr, fnames, fvalues, $
vcls, vtpes, scales, offsets, scaling, status, rows = rows, $
silent=silent, columns=columns, no_tdim=no_tdim, $
alias=alias, unsigned=unsigned, outalias=outalias,emptystring=emptystring
compile_opt idl2, hidden
;
; Header FITS header for table.
; Structyp IDL structure type to be used for
; structure.
; N_call Number of times this routine has been called.
; Table Structure to be defined.
; Status Return status.
; No_tdim Disable TDIM processing.
table = 0
types = ['L', 'X', 'B', 'I', 'J', 'K', 'A', 'E', 'D', 'C', 'M', 'P']
arrstr = ['bytarr(', 'bytarr(', 'bytarr(', 'intarr(', 'lonarr(', 'lon64arr(', $
'string(replicate(32b,', 'fltarr(', 'dblarr(', 'complexarr(', $
'dcomplexarr(', 'lonarr(2*']
bitpix = [ 0, 0, 0, 16, 32, 64, 0, 0, 0, 0, 0, 0]
sclstr = ["'T'", '0B', '0B', '0', '0L', '0LL', '" "', '0.', '0.d0', 'complex(0.,0.)', $
'dcomplex(0.d0,0.d0)', 'lonarr(2)']
if keyword_set(emptystring) then begin
sclstr[6] = '0B'
arrstr[6] = 'bytarr('
endif
unsarr = ['', '', '', 'uintarr(', 'ulonarr(', 'ulon64arr('];
unsscl = ['', '', '', '0US', '0UL', '0ULL']
status = 0
; NEW WAY: E.S.S.
;; get info from header. Using vectors is much faster
;; when there are many columns
eve_rwf_MRD_fxpar, header, xten, nfld, nrow, rsize, fnames, fforms, scales, offsets
nnames = n_elements(fnames)
tname = fnames
;; nrow will change later
nrows = nrow
;; Use scale=1 if not found
if nnames GT 0 then begin
wsc=where(scales EQ 0.0d,nwsc)
IF nwsc NE 0 THEN scales[wsc] = 1.0d
endif
xten = strtrim(xten,2)
if xten ne 'BINTABLE' and xten ne 'A3DTABLE' then begin
print, 'MRDFITS: ERROR - Header is not from binary table.'
nfld = 0 & status = -1
return
endif
if range[0] ge 0 then begin
range[0] = range[0] < (nrow-1)
range[1] = range[1] < (nrow-1)
endif else begin
range[0] = 0
range[1] = nrow - 1
endelse
nrow = range[1] - range[0] + 1
if nrow le 0 then begin
if ~keyword_set(silent) then $
print, 'MRDFITS: Binary table. ', $
strcompress(string(nfld)), ' columns, no rows.'
return
endif
if N_elements(rows) EQ 0 then nrowp = nrow else begin
bad = where((rows LT range[0]) or (rows GT range[1]), Nbad)
if Nbad GT 0 then begin
print,'MRDFITS: Row numbers must be between 0 and ' + $
strtrim(nrow-1,2)
status = -1
return
endif
nrowp = N_elements(rows)
endelse
; rsize = eve_rwf_FXpar(header, 'NAXIS1')
;
; Loop over the columns
typarr = strarr(nfld)
fvalues = strarr(nfld)
dimfld = strarr(nfld)
vcls = intarr(nfld)
vtpes = strarr(nfld)
fnames2 = strarr(nfld)
for i=0, nfld-1 do begin
istr = strcompress(string(i+1), /remo)
fname = fnames[i]
;; check for a name conflict
fname = eve_rwf_MRD_dofn(fname, i+1, use_colnum, alias=alias)
;; check for a name conflict
fname = eve_rwf_MRD_chkfn(fname, fnames2, i)
;; copy in the valid name
fnames[i] = fname
;; for checking conflicts
fnames2[i] = fname
fform = fforms[i]
eve_rwf_MRD_doff, fform, dim, ftype
; Treat arrays of length 1 as scalars.
if dim eq 1 then begin
dim = 0
endif else if dim EQ -1 then begin
dimfld[i] = -1
endif else begin
eve_rwf_MRD_tdim, header, i+1, dim, str, no_tdim=no_tdim
dimfld[i] = str
endelse
typarr[i] = ftype
; Find the number of bytes in a bit array.
if ftype eq 'X' && (dim gt 0) then begin
dim = (dim+7)/8
dimfld[i] = strtrim(string(dim),2)
endif
; Add in the structure label.
;
; Handle variable length columns.
if ftype eq 'P' then begin
if (dim ne 0) && (dim ne 1) then begin
print, 'MRDFITS: Invalid dimension for variable array column '+string(i+1)
status = -1
return
endif
ppos = strpos(fform, 'P')
vf = strmid(fform, ppos+1, 1);
if strpos('LXBIJKAEDCM', vf) eq -1 then begin
print, 'MRDFITS: Invalid type for variable array column '+string(i+1)
status = -1
return
endif
vcls[i] = 1
xunsigned = eve_rwf_MRD_chkunsigned(bitpix[ppos], scales[i], $
offsets[i], $
unsigned=unsigned)
if (xunsigned) then begin
if vf eq 'I' then vf = '1' $
else if vf eq 'J' then vf = '2' $
else if vf eq 'K' then vf = '3'
endif
vtpes[i] = vf
dim = 0
endif
for j=0, n_elements(types) - 1 do begin
if ftype eq types[j] then begin
xunsigned = eve_rwf_MRD_chkunsigned(bitpix[j], scales[i], $
offsets[i], $
unsigned=unsigned)
if xunsigned then begin
eve_rwf_fxaddpar, header, 'TZERO'+istr, 0, 'Modified by MRDFITS V'+eve_rwf_MRD_version()
offsets[i] = 0 ;; C. Markwardt Aug 2007 - reset to zero so offset is not applied twice'
endif
if dim eq 0 then begin
fvalues[i] = xunsigned ? unsscl[j] : sclstr[j]
endif else begin
line = xunsigned ? unsarr[j] : arrstr[j]
line = line + dimfld[i] + ')'
if not keyword_set(emptystring) then $
if ftype eq 'A' then line = line + ')'
fvalues[i] = line
endelse
goto, next_col
endif
endfor
print, 'MRDFITS: Invalid format code:',ftype, ' for column ', i+1
status = -1
return
next_col:
endfor
; Check if there are any variable length columns. If not then
; undefine vcls and vtpes
w = where(vcls eq 1, N_w)
if N_w eq 0 then begin
dummy = temporary(vcls)
dummy = temporary(vtpes)
dummy = 0
endif
if scaling then begin
w = where( (scales ne 1.0d0) or (offsets ne 0.0d0), Nw)
scaling = Nw GT 0
endif
zero = where(long(dimfld) LT 0L, N_zero)
if N_zero GT 0 then begin
if N_zero Eq nfld then begin
print,'MRDFITS: Error - All fields have zero length'
return
endif
for i=0, N_zero-1 do begin
print,'MRDFITS: Table column ' + fnames[zero[i]] + ' has zero length'
endfor
nfld = nfld - N_zero
good = where(dimfld GE 0)
fnames = fnames[good]
fvalues = fvalues[good]
typarr = typarr[good] ;Added 2005-1-6 (A.Csillaghy)
tname = tname[good]
endif
if n_elements(vcls) eq 0 && (~scaling) && ~keyword_set(columns) then begin
table = eve_rwf_MRD_struct(fnames, fvalues, nrow, structyp=structyp, silent=silent )
endif else begin
table = eve_rwf_MRD_struct(fnames, fvalues, nrow, silent=silent )
endelse
if ~keyword_set(silent) then begin
print, 'MRDFITS: Binary table. ',strcompress(string(nfld)), ' columns by ', $
strcompress(string(nrowp)), ' rows.'
if n_elements(vcls) gt 0 then begin
print, 'MRDFITS: Uses variable length arrays'
endif
endif
outalias = transpose([[tag_names(table)],[tname] ])
status = 0
return
end
;+
; NAME:
; MRDFITS
;
; PURPOSE:
; Read all standard FITS data types into arrays or structures.
;
; EXPLANATION:
; Further information on MRDFITS is available at
; http://idlastro.gsfc.nasa.gov/mrdfits.html
;
; **This version requires a post March 2009 version of fxposit.pro**
; CALLING SEQUENCE:
; Result = MRDFITS( Filename/FileUnit,[Exten_no/Exten_name, Header],
; /FPACK, /NO_FPACK, /FSCALE , /DSCALE , /UNSIGNED,
; ALIAS=strarr[2,n], /USE_COLNUM,
; /NO_TDIM, ROWS = [a,b,...], $
; /POINTER_VAR, /FIXED_VAR, EXTNUM=
; RANGE=[a,b], COLUMNS=[a,b,...]), ERROR_ACTION=x,
; COMPRESS=comp_prog, STATUS=status, /VERSION,
; /EMPTYSTRING )
;
; INPUTS:
; Filename = String containing the name of the file to be read or
; file number of an open unit. If an empty string is supplied,
; then user will be prompted for the file name. The user
; will also be prompted if a wild card is given in the file
; name, and there is more than one file name match.
; If the file name ends in .gz or .fz (or .Z on Unix systems)
; the file will be dynamically decompressed.
; or
; FiluUnit = An integer file unit which has already been
; opened for input. Data will be read from this
; unit and the unit will be left pointing immediately
; after the HDU that is read. Thus to read a compressed
; file with many HDU's a user might do something like:
; lun=fxposit(filename, 3) ; Skip the first three HDU's
; repeat begin
; thisHDU = mrdfits(lun, 0, hdr, status=status)
; ... process the HDU ...
; endrep until status lt 0
;
; Exten_no= Extension number to be read, 0 for primary array.
; Assumed 0 if not specified.
; If a unit rather than a filename
; is specified in the first argument, this is
; the number of HDU's to skip from the current position.
; Exten_name - Name of the extension to read (as stored in the EXTNAME
; keyword). This is a slightly slower method then specifying
; the extension number.
; OUTPUTS:
; Result = FITS data array or structure constructed from
; the designated extension. The format of result depends
; upon the type of FITS data read.
; Non-group primary array or IMAGE extension:
; A simple multidimensional array is returned with the
; dimensions given in the NAXISn keywords.
; Grouped image data with PCOUNT=0.
; As above but with GCOUNT treated as NAXIS(n+1).
; Grouped image data with PCOUNT>0.
; The data is returned as an array of structures. Each
; structure has two elements. The first is a one-dimensional
; array of the group parameters, the second is a multidimensional
; array as given by the NAXIS2-n keywords.
; ASCII and BINARY tables.
; The data is returned as a structure with one column for
; each field in the table. The names of the columns are
; normally taken from the TTYPE keywords (but see USE_COLNUM).
; Bit field columns
; are stored in byte arrays of the minimum necessary
; length. Spaces and invalid characters are replaced by
; underscores, and other invalid tag names are converted using
; the IDL_VALIDNAME(/CONVERT_ALL) function.
; Columns specified as variable length columns are stored
; with a dimension equal to the largest actual dimension
; used. Extra values in rows are filled with 0's or blanks.
; If the size of the variable length column is not
; a constant, then an additional column is created giving the
; size used in the current row. This additional column will
; have a tag name of the form L#_"colname" where # is the column
; number and colname is the column name of the variable length
; column. If the length of each element of a variable length
; column is 0 then the column is deleted.
;
;
; OPTIONAL OUTPUT:
; Header = String array containing the header from the FITS extension.
;
; OPTIONAL INPUT KEYWORDS:
; ALIAS The keyword allows the user to specify the column names
; to be created when reading FITS data. The value of
; this keyword should be a 2xn string array. The first
; value of each pair of strings should be the desired
; tag name for the IDL column. The second should be
; the FITS TTYPE value. Note that there are restrictions
; on valid tag names. The order of the ALIAS keyword
; is compatible with MWRFITS.
; COLUMNS - This keyword allows the user to specify that only a
; subset of columns is to be returned. The columns
; may be specified either as number 1,... n or by
; name or some combination of these two.
; If /USE_COLNUM is specified names should be C1,...Cn.
; The use of this keyword will not save time or internal
; memory since the extraction of specified columns
; is done after all columns have been retrieved from the
; FITS file. Structure columns are returned in the order
; supplied in this keyword.
; COMPRESS - This keyword allows the user to specify a
; decompression program to use to decompress a file that
; will not be automatically recognized based upon
; the file name.
; /DSCALE - As with FSCALE except that the resulting data is
; stored in doubles.
; /EMPTYSTRING - There was a bug in memory management for IDL versions
; prior to V8.0, causing a memory leak when reading
; empty strings in a FITS table. Setting /EMPTYSTRING will
; avoid this problem by first reading strings into bytes and
; then converting. However, there is a performance penalty.
; ERROR_ACTION - Set the on_error action to this value (defaults
; to 2).
; /FIXED_VAR- Translate variable length columns into fixed length columns
; and provide a length column for truly varying columns.
; This was only behavior prior to V2.5 for MRDFITS and remains
; the default (see /POINTER_VAR)
; /FPACK - If set, then assume the FITS file uses FPACK compression
; (http://heasarc.gsfc.nasa.gov/fitsio/fpack/). MRDFITS
; will automatically detect FPACK compressed files, but it is
; more efficient to supply the /FPACK keyword. A file with an
; extension of .fz is assumed to be Fpack compressed.
; /NO_FPACK - If present, then MRDFITS will not uncompress an extension
; compressed with FPACK, but will just read the compressed
; binary stream.
; /FSCALE - If present and non-zero then scale data to float
; numbers for arrays and columns which have either
; non-zero offset or non-unity scale.
; If scaling parameters are applied, then the corresponding
; FITS scaling keywords will be modified.
; NO_TDIM - Disable processing of TDIM keywords. If NO_TDIM
; is specified MRDFITS will ignore TDIM keywords in
; binary tables.
; /POINTER_VAR- Use pointer arrays for variable length columns.
; In addition to changing the format in which
; variable length arrays are stored, if the pointer_var
; keyword is set to any value other than 1 this also disables
; the deletion of variable length columns. (See /FIXED_VAR)
; Note that because pointers may be present in the output
; structure, the user is responsible for memory management
; when deleting or reassigning the structure (e.g. use HEAP_FREE
; first).
; RANGE - A scalar or two element vector giving the start
; and end rows to be retrieved. For ASCII and BINARY
; tables this specifies the row number. For GROUPed data
; this will specify the groups. For array images, this
; refers to the last non-unity index in the array. E.g.,
; for a 3 D image with NAXIS* values = [100,100,1], the
; range may be specified as 0:99, since the last axis
; is suppressed. Note that the range uses IDL indexing
; So that the first row is row 0.
; If only a single value, x, is given in the range,
; the range is assumed to be [0,x-1].
; ROWS - A scalar or vector specifying a specific row or rows to read
; (first row is 0). For example to read rows 0,
; 12 and 23 only, set ROWS=[0,12,23]. Valid for images, ASCII
; and binary tables, but not GROUPed data. For images
; the row numbers refer to the last non-unity index in the array.
; Note that the use of the ROWS will not improve the speed of
; MRDFITS since the entire table will be read in, and then subset
; to the specified rows. Cannot be used at the same time as
; the RANGE keyword
; /SILENT - Suppress informative messages.
; STRUCTYP - The structyp keyword specifies the name to be used
; for the structure defined when reading ASCII or binary
; tables. Generally users will not be able to conveniently
; combine data from multiple files unless the STRUCTYP
; parameter is specified. An error will occur if the
; user specifies the same value for the STRUCTYP keyword
; in calls to MRDFITS in the same IDL session for extensions
; which have different structures.
; /UNSIGNED - For integer data with appropriate zero points and scales
; read the data into unsigned integer arrays.
; /USE_COLNUM - When creating column names for binary and ASCII tables
; MRDFITS attempts to use the appropriate TTYPE keyword
; values. If USE_COLNUM is specified and non-zero then
; column names will be generated as 'C1, C2, ... 'Cn'
; for the number of columns in the table.
; /VERSION Print the current version number
;
; OPTIONAL OUTPUT KEYWORDS:
; EXTNUM - the number of the extension actually read. Useful if the
; user specified the extension by name.
; OUTALIAS - This is a 2xn string array where the first column gives the
; actual structure tagname, and the second gives the
; corresponding FITS keyword name (e.g. in the TTYPE keyword).
; This array can be passed directly to
; the alias keyword of MWRFITS to recreate the file originally
; read by MRDFITS.
; STATUS - A integer status indicating success or failure of
; the request. A status of >=0 indicates a successful read.
; Currently
; 0 -> successful completion
; -1 -> error
; -2 -> end of file
;
; EXAMPLES:
; (1) Read a FITS primary array:
; a = mrdfits('TEST.FITS') or
; a = mrdfits('TEST.FITS', 0, header)
; The second example also retrieves header information.
;
; (2) Read rows 10-100 of the second extension of a FITS file.
; a = mrdfits('TEST.FITS', 2, header, range=[10,100])
;
; (3) Read a table and ask that any scalings be applied and the
; scaled data be converted to doubles. Use simple column names,
; suppress outputs.
; a = mrdfits('TEST.FITS', 1, /dscale, /use_colnum, /silent)
;
; (4) Read rows 3, 34 and 52 of a binary table and request that
; variable length columns be stored as a pointer variable in the
; output structure
; a = mrdfits('TEST.FITS',1,rows=[3,34,52],/POINTER)
; RESTRICTIONS:
; (1) Cannot handle data in non-standard FITS formats.
; (2) Doesn't do anything with BLANK or NULL values or
; NaN's. They are just read in. They may be scaled
; if scaling is applied.
; NOTES:
; This multiple format FITS reader is designed to provide a
; single, simple interface to reading all common types of FITS data.
; MRDFITS DOES NOT scale data by default. The FSCALE or DSCALE
; parameters must be used.
;
; Null values in an FITS ASCII table are converted to NaN (floating data),
; or -2147483647L (longwords) or '...' (strings).
;
; PROCEDURES USED:
; The following procedures are contained in the main MRDFITS program.
; MRD_IMAGE -- Generate array/structure for images.
; MRD_READ_IMAGE -- Read image data.
; MRD_ASCII -- Generate structure for ASCII tables.
; MRD_READ_ASCII -- Read an ASCII table.
; MRD_TABLE -- Generate structure for Binary tables.
; MRD_READ_TABLE -- Read binary table info.
; MRD_READ_HEAP -- Read variable length record info.
; MRD_SCALE -- Apply scaling to data.
; MRD_COLUMNS -- Extract columns.
;
; Other ASTRON Library routines used
; FXPAR(), FXADDPAR, FXPOSIT, FXMOVE(), MATCH, MRD_STRUCT(), MRD_SKIP
;
; MODIfICATION HISTORY:
; V1.0 November 9, 1994 ---- Initial release.
; Creator: Thomas A. McGlynn
; V1.1 January 20, 1995 T.A. McGlynn
; Fixed bug in variable length records.
; Added TDIM support -- new routine mrd_tdim in MRD_TABLE.
; V1.2
; Added support for dynamic decompression of files.
; Fixed further bugs in variable length record handling.
; V1.2a
; Added NO_TDIM keyword to turn off TDIM processing for
; those who don't want it.
; Bug fixes: Handle one row tables correctly, use BZERO rather than
; BOFFSET. Fix error in scaling of images.
; V1.2b
; Changed MRD_HREAD to handle null characters in headers.
; V2.0 April 1, 1996
; -Handles FITS tables with an arbitrary number of columns.
; -Substantial changes to MRD_STRUCT to allow the use of
; substructures when more than 127 columns are desired.
; -All references to table columns are now made through the
; functions MRD_GETC and MRD_PUTC. See description above.
; -Use of SILENT will now eliminate compilation messages for
; temporary functions.
; -Bugs in handling of variable length columns with either
; a single row in the table or a maximum of a single element
; in the column fixed.
; -Added support for DCOMPLEX numbers in binary tables (M formats) for
; IDL versions above 4.0.
; -Created regression test procedure to check in new versions.
; -Added error_action parameter to allow user to specify
; on_error action. This should allow better interaction with
; new CHECK facility. ON_ERROR statements deleted from
; most called routines.
; - Modified MRDFITS to read in headers containing null characters
; with a warning message printed.
; V2.0a April 16, 1996
; - Added IS_IEEE_BIG() checks (and routine) so that we don't
; worry about IEEE to host conversions if the machine's native
; format is IEEE Big-endian.
; V2.1 August 24, 1996
; - Use resolve_routine for dynamically defined functions
; for versions > 4.0
; - Fix some processing in random groups format.
; - Handle cases where the data segment is--legally--null.
; In this case MRDFITS returns a scalar 0.
; - Fix bugs with the values for BSCALE and BZERO (and PSCAL and
; PZERO) parameters set by MRDFITS.
; V2.1a April 24, 1997 Handle binary tables with zero length columns
; V2.1b May 13,1997 Remove whitespace from replicate structure definition
; V2.1c May 28,1997 Less strict parsing of XTENSION keyword
; V2.1d June 16, 1997 Fixed problem for >32767 entries introduced 24-Apr
; V2.1e Aug 12, 1997 Fixed problem handling double complex arrays
; V2.1f Oct 22, 1997 IDL reserved words can't be structure tag names
; V2.1g Nov 24, 1997 Handle XTENSION keywords with extra blanks.
; V2.1h Jul 26, 1998 More flexible parsing of TFORM characters
; V2.2 Dec 14, 1998 Allow fields with longer names for
; later versions of IDL.
; Fix handling of arrays in scaling routines.
; Allow >128 fields in structures for IDL >4.0
; Use more efficient structure copying for
; IDL>5.0
; V2.2b June 17, 1999 Fix bug in handling case where
; all variable length columns are deleted
; because they are empty.
; V2.3 March 7, 2000 Allow user to supply file handle rather
; than file name.
; Added status field.
; Now needs FXMOVE routine
; V2.3b April 4, 2000
; Added compress option (from D. Palmer)
; V2.4 July 4, 2000 Added STATUS=-1 for "File access error" (Zarro/GSFC)
; V2.4a May 2, 2001 Trim binary format string (W. Landsman)
; V2.5 December 5, 2001 Add unsigned, alias, 64 bit integers. version, $
; /pointer_val, /fixed_var.
; V2.5a Fix problem when both the first and the last character
; in a TTYPEnn value are invalid structure tag characters
; V2.6 February 15, 2002 Fix error in handling unsigned numbers, $
; and 64 bit unsigneds. (Thanks to Stephane Beland)
; V2.6a September 2, 2002 Fix possible conflicting data structure for
; variable length arrays (W. Landsman)
; V2.7 July, 2003 Added Rows keyword (W. Landsman)
; V2.7a September 2003 Convert dimensions to long64 to handle huge files
; V2.8 October 2003 Use IDL_VALIDNAME() function to ensure valid tag names
; Removed OLD_STRUCT and TEMPDIR keywords W. Landsman
; V2.9 February 2004 Added internal MRD_FXPAR procedure for faster
; processing of binary table headers E. Sheldon
; V2.9a March 2004 Restore ability to read empty binary table W. Landsman
; Swallow binary tables with more columns than given in TFIELDS
; V2.9b Fix to ensure order of TFORMn doesn't matter
; V2.9c Check if extra degenerate NAXISn keyword are present W.L. Oct 2004
; V2.9d Propagate /SILENT to MRD_HREAD, more LONG64 casting W. L. Dec 2004
; V2.9e Add typarr[good] to fix a problem reading zero-length columns
; A.Csillaghy, csillag@ssl.berkeley.edu (RHESSI)
; V2.9f Fix problem with string variable binary tables, possible math
; overflow on non-IEEE machines WL Feb. 2005
; V2.9g Fix problem when setting /USE_COLNUM WL Feb. 2005
; V2.10 Use faster keywords to BYTEORDER WL May 2006
; V2.11 Add ON_IOERROR, CATCH, and STATUS keyword to MRD_READ_IMAGE to
; trap EOF in compressed files DZ Also fix handling of unsigned
; images when BSCALE not present K Chu/WL June 2006
; V2.12 Allow extension to be specified by name, added EXTNUM keyword
; WL December 2006
; V2.12a Convert ASCII table column to DOUBLE if single precision is
; insufficient
; V2.12b Fixed problem when both /fscale and /unsigned are set
; C. Markwardt Aug 2007
; V2.13 Use SWAP_ENDIAN_INPLACE instead of IEEE_TO_HOST and IS_IEEE_BIG
; W. Landsman Nov 2007
; V2.13a One element vector allowed for file name W.L. Dec 2007
; V2.13b More informative error message when EOF found W.L. Jun 2008
; V2.14 Use vector form of VALID_NUM(), added OUTALIAS keyword
; W.L. Aug 2008
; V2.15 Use new FXPOSIT which uses on-the-fly byteswapping W.L. Mar 2009
; V2.15a Small efficiency updates to MRD_SCALE W.L. Apr 2009
; V2.15b Fixed typo introduced Apr 2009
; V2.15c Fix bug introduced Mar 2009 when file unit used W.L. July 2009
; V2.16 Handle FPACK compressed files W. L. July 2009
; V2.17 Use compile_opt hidden on all routines except mrdfits.pro W.L. July 2009
; V2.18 Added /EMPTYSTRING keyword W. Landsman August 2009
; V2.18a Fix Columns keyword output, A. Kimball/ W. Landsman Feb 2010
; V2.18b Fix bug with /EMPTYSTRING and multidimensional strings
; S. Baldridge/W.L. August 2010
; V2.18c Fix unsigned bug caused by compile_opt idl2 WL Nov 2010
; V2.19 Use V6.0 operators WL Nov 2010
; V2.19a Fix complex data conversion in variable length tables WL Dec 2010
; V2.19b Fix bug with /FSCALE introduced Nov 2010 WL Jan 2011
; V2.19c Fix bug with ROWS keyword introduced Nov 2010 WL Mar 2011
; V2.20 Convert Nulls in ASCII tables, better check of duplicate keywords
;:Private:
;-
function eve_rwf_mrdfits, file, extension, header, $
structyp = structyp, $
use_colnum = use_colnum, $
range = range, $
dscale = dscale, fscale=fscale, $
fpack = fpack, no_fpack = no_fpack, $
silent = silent, $
columns = columns, $
no_tdim = no_tdim, $
error_action = error_action, $
compress=compress, $
alias=alias, $
rows = rows, $
unsigned=unsigned, $
version=version, $
pointer_var=pointer_var, $
fixed_var=fixed_var, $
outalias = outalias, $
emptystring = emptystring, $
status=status, extnum = extnum
compile_opt idl2
; Let user know version if MRDFITS being used.
if keyword_set(version) then $
print,'MRDFITS: Version '+eve_rwf_MRD_version() + 'April 29, 2011'
if N_elements(error_action) EQ 0 then error_action = 2
On_error, error_action
; Check positional arguments.
if n_params() le 0 || n_params() gt 3 then begin
if keyword_set(version) then return, 0
print, 'MRDFITS: Usage'
print, ' a=mrdfits(file/unit, [exten_no/exten_name, header], /version $'
print, ' /fscale, /dscale, /unsigned, /use_colnum, /silent $'
print, ' range=, rows= , structyp=, columns=, $'
print, ' /pointer_var, /fixed_var, error_action=, status= )'
return, 0
endif
if n_params() eq 1 then extension = 0
; Check optional arguments.
;
; *** Structure name ***
if keyword_set(structyp) then begin
sz = size(structyp)
if sz[0] ne 0 then begin
; Use first element of array
structyp = structyp[0]
sz = size(structyp[0])
endif
if sz[1] ne 7 then begin
print, 'MRDFITS: stucture type must be a string'
return, 0
endif
endif
; *** Use column numbers not names?
use_colnum = keyword_set(use_colnum)
; *** Get only a part of the FITS file.
if N_elements(rows) GT 0 then begin
range1 = min(rows,max=range2)
range = [range1,range2]
endif
if keyword_set(range) then begin
if n_elements(range) eq 2 then arange = range $
else if n_elements(range) eq 1 then arange = [0,range[0]-1] $
else if n_elements(range) gt 2 then arange = range[0:1] $
else if n_elements(range) eq 0 then arange = [-1,-1]
endif else begin
arange = [-1,-1]
endelse
arange = long(arange)
; Open the file and position to the appropriate extension then read
; the header.
if (N_elements(file) GT 1 ) then begin
print, 'MRDFITS: Vector input not supported'
return, 0
endif
inputUnit = 0
dtype = size(file,/type)
if (dtype gt 0) && (dtype lt 4) then begin ;File unit number specified
inputUnit = 1
unit = file
unixpipe = (fstat(unit)).size EQ 0 ;Unix pipes have no files size
if eve_rwf_FXmove(unit,extension) lt 0 then return, -1
endif else begin ;File name specified
unit = eve_rwf_FXposit(file, extension, compress=compress, unixpipe=unixpipe, $
/readonly,extnum=extnum, errmsg= errmsg, fpack=fpack)
if unit lt 0 then begin
message, 'File access error',/CON
if errmsg NE '' then message,errmsg,/CON
status = -1
return, 0
endif
endelse
if eof(unit) then begin
message,'ERROR - Extension past EOF',/CON
if inputUnit eq 0 then free_lun,unit
status = -2
return, 0
endif
eve_rwf_MRD_hread, unit, header, status, SILENT = silent, ERRMSG = errmsg
if status lt 0 then begin
message,'ERROR - ' +errmsg,/CON
message, 'ERROR - FITS file may be invalid or corrupted',/CON
if inputUnit eq 0 then free_lun,unit
return, 0
endif
; If the ZIMAGE keyword is present in the header, then we must re-open the
; file using a pipe.
if ~keyword_set(no_fpack) then $
if (inputunit EQ 0) && (~unixpipe) then begin
if eve_rwf_sxpar(header,'ZIMAGE') then begin
free_lun,unit
unit = eve_rwf_FXposit(file, extension, compress=compress, /fpack, $
unixpipe=unixpipe,/readonly,extnum=extnum, errmsg= errmsg)
eve_rwf_MRD_hread, unit, header, status, SILENT = silent, ERRMSG = errmsg
endif
endif
; If this is primary array then XTENSION will have value
; 0 which will be converted by strtrim to '0'
xten = strtrim( eve_rwf_FXpar(header,'XTENSION'), 2)
if xten eq '0' || xten eq 'IMAGE' then type = 0 $
else if xten eq 'TABLE' then type = 1 $
else if xten eq 'BINTABLE' || xten eq 'A3DTABLE' then type = 2 $
else begin
message, 'Unable to process extension type:' + strtrim(xten,2),/CON
if inputUnit eq 0 then free_lun,unit
status = -1
return, 0
endelse
scaling = keyword_set(fscale) or keyword_set(dscale)
if type eq 0 then begin
;*** Images/arrays
eve_rwf_MRD_image, header, arange, maxd, rsize, table, scales, offsets, $
scaling, status, silent=silent, unsigned=unsigned, $
rows= rows
if (status ge 0) && (rsize gt 0) then begin
eve_rwf_MRD_read_image, unit, arange, maxd, rsize, table, rows = rows,$
status=status, unixpipe=unixpipe
endif
size = rsize
endif else if type eq 1 then begin
;*** ASCII tables.
eve_rwf_MRD_ascii, header, structyp, use_colnum, $
arange, table, nbytes, nrows, nfld, rows=rows, $
typarr, posarr, lenarr, nullarr, fnames, fvalues, $
scales, offsets, scaling, status, silent=silent, $
columns=columns, alias=alias, outalias=outalias
size = nbytes*nrows
if (status ge 0) && (size gt 0) then begin
;*** Read data.
eve_rwf_MRD_read_ascii, unit, arange, nbytes, nrows, $
nfld, typarr, posarr, lenarr, nullarr, table, rows= rows
;*** Extract desired columns.
if (status ge 0) && keyword_set(columns) then $
eve_rwf_MRD_columns, table, columns, fnames, fvalues, vcls, vtps, $
scales, offsets, scaling, structyp=structyp, silent=silent
endif
endif else begin
; *** Binary tables.
eve_rwf_MRD_table, header, structyp, use_colnum, $
arange, rsize, table, nrows, nfld, typarr, $
fnames, fvalues, vcls, vtpes, scales, offsets, scaling, status, $
silent=silent, columns=columns, no_tdim=no_tdim, $
alias=alias, unsigned=unsigned, rows = rows, outalias = outalias, $
emptystring=emptystring
size = nfld*(arange[1] - arange[0] + 1)
if (status ge 0) && (size gt 0) then begin
;*** Read data.
eve_rwf_MRD_read_table, unit, arange, rsize, rows = rows, $
structyp, nrows, nfld, typarr, table, unixpipe=unixpipe
if (status ge 0) && keyword_set(columns) then begin
;*** Extract desired columns.
eve_rwf_MRD_columns, table, columns, fnames, fvalues, $
vcls, vtpes, scales, offsets, scaling, structyp=structyp, $
silent=silent
endif
if keyword_set(emptystring) then $
eve_rwf_MRD_string, table, header, typarr, $
fnames, fvalues, 1+arange[1]-arange[0], structyp=structyp, silent=silent
if (status ge 0) && n_elements(vcls) gt 0 then begin
;*** Get variable length columns
eve_rwf_MRD_read_heap, unit, header, arange, fnames, fvalues, $
vcls, vtpes, table, structyp, scaling, scales, offsets, status, $
silent=silent, pointer_var=pointer_var, fixed_var=fixed_var, rows= rows
endif else begin
; Skip remainder of last data block
sz = long64(eve_rwf_FXpar(header, 'NAXIS1'))* $
long64(eve_rwf_FXpar(header,'NAXIS2')) + $
long64(eve_rwf_FXpar(header, 'PCOUNT'))
skipB = 2880 - sz mod 2880
if (skipB ne 2880) then eve_rwf_MRD_skip, unit, skipB
endelse
endif
endelse
; Don't tie up a unit number that we allocated in this routine.
if (unit gt 0) && (inputUnit eq 0) then free_lun, unit
; If any of the scales are non-unity, or any of the offsets are nonzero then
; apply scalings.
if (status ge 0) && scaling && (size gt 0) then begin
noscale = array_equal(scales,1.d0) && array_equal(offsets,0.0)
if ~noscale then eve_rwf_MRD_scale, type, scales, offsets, table, header, $
fnames, fvalues, 1+arange[1]-arange[0], structyp=structyp, $
dscale=dscale, silent=silent
endif
; All done. Check the status to see if we ran into problems on the way.
if status ge 0 then return, table else return,0
end
;+
; NAME:
; SXPAR
; PURPOSE:
; Obtain the value of a parameter in a FITS header
;
; CALLING SEQUENCE:
; result = SXPAR( Hdr, Name, [ Abort, COUNT=, COMMENT =, /NoCONTINUE,
; /SILENT ])
;
; INPUTS:
; Hdr = FITS header array, (e.g. as returned by READFITS)
; string array, each element should have a length of 80 characters
;
; Name = String name of the parameter to return. If Name is of the
; form 'keyword*' then an array is returned containing values of
; keywordN where N is an integer. The value of keywordN will be
; placed in RESULT(N-1). The data type of RESULT will be the
; type of the first valid match of keywordN found.
;
; OPTIONAL INPUTS:
; ABORT - string specifying that SXPAR should do a RETALL
; if a parameter is not found. ABORT should contain
; a string to be printed if the keyword parameter is not found.
; If not supplied, SXPAR will return quietly with COUNT = 0
; (and !ERR = -1) if a keyword is not found.
;
; OPTIONAL INPUT KEYWORDS:
; /NOCONTINUE = If set, then continuation lines will not be read, even
; if present in the header
; /SILENT - Set this keyword to suppress warning messages about duplicate
; keywords in the FITS header.
;
; OPTIONAL OUTPUT KEYWORDS:
; COUNT - Optional keyword to return a value equal to the number of
; parameters found by SXPAR, integer scalar
;
; COMMENT - Array of comments associated with the returned values
;
; OUTPUTS:
; Function value = value of parameter in header.
; If parameter is double precision, floating, long or string,
; the result is of that type. Apostrophes are stripped
; from strings. If the parameter is logical, 1b is
; returned for T, and 0b is returned for F.
; If Name was of form 'keyword*' then a vector of values
; are returned.
;
; SIDE EFFECTS:
; !ERR is set to -1 if parameter not found, 0 for a scalar
; value returned. If a vector is returned it is set to the
; number of keyword matches found. The use of !ERR is deprecated, and
; instead the COUNT keyword is preferred
;
; If a keyword (except HISTORY or COMMENT) occurs more than once in a
; header, a warning is given, and the *last* occurence is used.
;
; EXAMPLES:
; Given a FITS header, h, return the values of all the NAXISi values
; into a vector. Then place the history records into a string vector.
;
; IDL> naxisi = sxpar( h ,'NAXIS*') ; Extract NAXISi value
; IDL> history = sxpar( h, 'HISTORY' ) ; Extract HISTORY records
;
; PROCEDURE:
; The first 8 chacters of each element of Hdr are searched for a
; match to Name. The value from the last 20 characters is returned.
; An error occurs if there is no parameter with the given name.
;
; If a numeric value has no decimal point it is returned as type
; LONG. If it contains more than 8 numerals, or contains the
; characters 'D' or 'E', then it is returned as type DOUBLE. Otherwise
; it is returned as type FLOAT. Very large integer values, outside
; the range of valid LONG, are returned as DOUBLE.
;
; If the value is too long for one line, it may be continued on to the
; the next input card, using the OGIP CONTINUE convention. For more info,
; see http://fits.gsfc.nasa.gov/registry/continue_keyword.html
;
; Complex numbers are recognized as two numbers separated by one or more
; space characters.
;
; If a numeric value has no decimal point (or E or D) it is returned as
; type LONG. If it contains more than 8 numerals, or contains the
; character 'D', then it is returned as type DOUBLE. Otherwise it is
; returned as type FLOAT. If an integer is too large to be stored as
; type LONG, then it is returned as DOUBLE.
;
; NOTES:
; The functions SXPAR() and FXPAR() are nearly identical, although
; FXPAR() has slightly more sophisticated parsing, and additional keywords
; to specify positions in the header to search (for speed), and to force
; the output to a specified data type.. There is no
; particular reason for having two nearly identical procedures, but
; both are too widely used to drop either one.
;
; PROCEDURES CALLED:
; GETTOK(), VALID_NUM()
; MODIFICATION HISTORY:
; DMS, May, 1983, STPAR Written.
; D. Lindler Jan 90 added ABORT input parameter
; J. Isensee Jul,90 added COUNT keyword
; W. Thompson, Feb. 1992, added support for FITS complex values.
; W. Thompson, May 1992, corrected problem with HISTORY/COMMENT/blank
; keywords, and complex value error correction.
; W. Landsman, November 1994, fix case where NAME is an empty string
; W. Landsman, March 1995, Added COMMENT keyword, ability to read
; values longer than 20 character
; W. Landsman, July 1995, Removed /NOZERO from MAKE_ARRAY call
; T. Beck May 1998, Return logical as type BYTE
; W. Landsman May 1998, Make sure integer values are within range of LONG
; W. Landsman Feb 1998, Recognize CONTINUE convention
; W. Landsman Oct 1999, Recognize numbers such as 1E-10 as floating point
; W. Landsman Jan 2000, Only accept integer N values when name = keywordN
; W. Landsman Dec 2001, Optional /SILENT keyword to suppress warnings
; W. Landsman/D. Finkbeiner Mar 2002 Make sure extracted vectors
; of mixed data type are returned with the highest type.
; W.Landsman Aug 2008 Use vector form of VALID_NUM()
; W. Landsman Jul 2009 Eliminate internal recursive call
;:Private:
;-
function eve_rwf_SXPAR, hdr, name, abort, COUNT=matches, COMMENT = comments, $
NoContinue = NoContinue, SILENT = silent
;----------------------------------------------------------------------
On_error,2
compile_opt idl2
if N_params() LT 2 then begin
print,'Syntax - result = sxpar( hdr, name, [abort])'
print,' Input Keywords: /NOCONTINUE, /SILENT'
print,' Output Keywords: COUNT=, COMMENT= '
return, -1
endif
VALUE = 0
if N_params() LE 2 then begin
abort_return = 0
abort = 'FITS Header'
end else abort_return = 1
if abort_return then On_error,1 else On_error,2
; Check for valid header
;Check header for proper attributes.
if ( size(hdr,/N_dimen) NE 1 ) or ( size(hdr,/type) NE 7 ) then $
message,'FITS Header (first parameter) must be a string array'
nam = strtrim( strupcase(name) ) ;Copy name, make upper case
; Determine if NAME is of form 'keyword*'. If so, then strip off the '*', and
; set the VECTOR flag. One must consider the possibility that NAM is an empty
; string.
namelength1 = (strlen(nam) - 1 ) > 1
if strpos( nam, '*' ) EQ namelength1 then begin
nam = strmid( nam, 0, namelength1)
vector = 1 ;Flag for vector output
name_length = strlen(nam) ;Length of name
num_length = 8 - name_length ;Max length of number portion
if num_length LE 0 then $
message, 'Keyword length must be 8 characters or less'
; Otherwise, extend NAME with blanks to eight characters.
endif else begin
while strlen(nam) LT 8 do nam = nam + ' ' ;Make 8 chars long
vector = 0
endelse
; If of the form 'keyword*', then find all instances of 'keyword' followed by
; a number. Store the positions of the located keywords in NFOUND, and the
; value of the number field in NUMBER.
histnam = (nam eq 'HISTORY ') or (nam eq 'COMMENT ') or (nam eq '')
keyword = strmid( hdr, 0, 8)
if vector then begin
nfound = where(strpos(keyword,nam) GE 0, matches)
if matches GT 0 then begin
numst= strmid( hdr[nfound], name_length, num_length)
igood = where(eve_rwf_valid_num(numst,/INTEGER), matches)
if matches GT 0 then begin
nfound = nfound[igood]
number = long(numst[igood])
endif
endif
; Otherwise, find all the instances of the requested keyword. If more than
; one is found, and NAME is not one of the special cases, then print an error
; message.
endif else begin
nfound = where(keyword EQ nam, matches)
if (matches GT 1) and ~histnam then $
if ~keyword_set(silent) then $
message,/informational, 'Warning - keyword ' + $
nam + ' located more than once in ' + abort
endelse
; Process string parameter
if matches GT 0 then begin
line = hdr[nfound]
svalue = strtrim( strmid(line,9,71),2)
if histnam then $
value = strtrim(strmid(line,8,71),2) else for i = 0,matches-1 do begin
if ( strmid(svalue[i],0,1) EQ "'" ) then begin ;Is it a string?
test = strmid( svalue[i],1,strlen( svalue[i] )-1)
next_char = 0
off = 0
value = ''
NEXT_APOST:
endap = strpos(test, "'", next_char) ;Ending apostrophe
if endap LT 0 then $
MESSAGE,'Value of '+name+' invalid in '+abort
value = value + strmid( test, next_char, endap-next_char )
; Test to see if the next character is also an apostrophe. If so, then the
; string isn't completed yet. Apostrophes in the text string are signalled as
; two apostrophes in a row.
if strmid( test, endap+1, 1) EQ "'" then begin
value = value + "'"
next_char = endap+2
goto, NEXT_APOST
endif
; Extract the comment, if any
slash = strpos( test, "/", endap )
if slash LT 0 then comment = '' else $
comment = strmid( test, slash+1, strlen(test)-slash-1 )
; This is a string that could be continued on the next line. Check this
; possibility with the following four criteria: *1) Ends with '&'
; (2) Next line is CONTINUE (3) LONGSTRN keyword is present (recursive call to
; SXPAR) 4. /NOCONTINE is not set
if ~keyword_set(nocontinue) then begin
off = off + 1
val = strtrim(value,2)
if (strlen(val) gt 0) && $
(strmid(val, strlen(val)-1, 1) EQ '&') && $
(strmid(hdr[nfound[i]+off],0,8) EQ 'CONTINUE') then $
if ~array_equal(keyword EQ 'LONGSTRN',0b) then begin
value = strmid(val, 0, strlen(val)-1)
test = hdr[nfound[i]+off]
test = strmid(test, 8, strlen(test)-8)
test = strtrim(test, 2)
if strmid(test, 0, 1) NE "'" then message, $
'ERROR: Invalidly CONTINUEd string in '+ abort
next_char = 1
GOTO, NEXT_APOST
ENDIF
ENDIF
; Process non-string value
endif else begin
test = svalue[i]
slash = strpos( test, "/" )
if slash GT 0 then begin
comment = strmid( test, slash+1, strlen(test)-slash-1 )
test = strmid( test, 0, slash )
end else comment = ''
; Find the first word in TEST. Is it a logical value ('T' or 'F')
test2 = test
value = eve_rwf_gettok(test2,' ')
if ( value EQ 'T' ) then value = 1b else $
if ( value EQ 'F' ) then value = 0b else begin
; Test to see if a complex number. It's a complex number if the value and
; the next word, if any, are both valid values.
if strlen(test2) EQ 0 then goto, NOT_COMPLEX
value2 = eve_rwf_gettok( test2, ' ')
if value2 EQ '' then goto, NOT_COMPLEX
On_ioerror, NOT_COMPLEX
value2 = float(value2)
value = complex(value,value2)
goto, GOT_VALUE
; Not a complex number. Decide if it is a floating point, double precision,
; or integer number.
NOT_COMPLEX:
On_IOerror, GOT_VALUE
if (strpos(value,'.') GE 0) or (strpos(value,'E') GT 0) $
or (strpos(value,'D') GE 0) then begin ;Floating or double?
if ( strpos(value,'D') GT 0 ) or $ ;Double?
( strlen(value) GE 8 ) then value = double(value) $
else value = float(value)
endif else begin ;Long integer
lmax = 2.0d^31 - 1.0d
lmin = -2.0d^31 ;Typo fixed Feb 2010
value = double(value)
if (value GE lmin) && (value LE lmax) then $
value = long(value)
endelse
GOT_VALUE:
On_IOerror, NULL
endelse
endelse; if c eq apost
; Add to vector if required
if vector then begin
if ( i EQ 0 ) then begin
maxnum = max(number)
dtype = size(value,/type)
result = make_array( maxnum, TYPE = dtype )
comments = strarr( maxnum )
endif
if size(value,/type) GT dtype then begin ;Do we need to recast?
result = result + 0*value
dtype = size(value,/type)
endif
result[ number[i]-1 ] = value
comments[ number[i]-1 ] = comment
endif else $
comments = comment
endfor
if vector then begin
!ERR = matches
return, result
endif else !ERR = 0
endif else begin
if abort_return then message,'Keyword '+nam+' not found in '+abort
!ERR = -1
endelse
return, value
END
;
;+
; This is a utility routine, which splits a parameter into several
; continuation bits.
;:Private:
;-
PRO eve_rwf_FXADDPAR_CONTPAR, VALUE, CONTINUED
APOST = "'"
BLANK = STRING(REPLICATE(32B,80)) ;BLANK line
;; The value may not need to be CONTINUEd. If it does, then split
;; out the first value now. The first value does not have a
;; CONTINUE keyword, because it will be grafted onto the proper
;; keyword in the calling routine.
IF (STRLEN(VALUE) GT 68) THEN BEGIN
CONTINUED = [ STRMID(VALUE, 0, 67)+'&' ]
VALUE = STRMID(VALUE, 67, STRLEN(VALUE)-67)
ENDIF ELSE BEGIN
CONTINUED = [ VALUE ]
RETURN
ENDELSE
;; Split out the remaining values.
WHILE( STRLEN(VALUE) GT 0 ) DO BEGIN
H = BLANK
;; Add CONTINUE keyword
STRPUT, H, 'CONTINUE '+APOST
;; Add the next split
IF(STRLEN(VALUE) GT 68) THEN BEGIN
STRPUT, H, STRMID(VALUE, 0, 67)+'&'+APOST, 11
VALUE = STRMID(VALUE, 67, STRLEN(VALUE)-67)
ENDIF ELSE BEGIN
STRPUT, H, VALUE+APOST, 11
VALUE = ''
ENDELSE
CONTINUED = [ CONTINUED, H ]
ENDWHILE
RETURN
END
;+
; Utility routine to add a warning to the file. The calling routine
; must ensure that the header is in a consistent state before calling
; FXADDPAR_CONTWARN because the header will be subsequently modified
; by calls to FXADDPAR.
;:Private:
;-
PRO eve_rwf_FXADDPAR_CONTWARN, HEADER, NAME
; By OGIP convention, the keyword LONGSTRN is added to the header as
; well. It should appear before the first occurrence of a long
; string encoded with the CONTINUE convention.
CONTKEY = eve_rwf_FXPAR(HEADER, 'LONGSTRN', COUNT = N_LONGSTRN)
; Calling FXADDPAR here is okay since the state of the header is
; clean now.
IF N_LONGSTRN GT 0 THEN $
RETURN
eve_rwf_FXADDPAR, HEADER, 'LONGSTRN', 'OGIP 1.0', $
' The OGIP long string convention may be used.', $
BEFORE=NAME
eve_rwf_FXADDPAR, HEADER, 'COMMENT', $
' This FITS file may contain long string keyword values that are', $
BEFORE=NAME
eve_rwf_FXADDPAR, HEADER, 'COMMENT', $
" continued over multiple keywords. This convention uses the '&'", $
BEFORE=NAME
eve_rwf_FXADDPAR, HEADER, 'COMMENT', $
' character at the end of a string which is then continued', $
BEFORE=NAME
eve_rwf_FXADDPAR, HEADER, 'COMMENT', $
" on subsequent keywords whose name = 'CONTINUE'.", $
BEFORE=NAME
RETURN
END
;+
; NAME:
; FXPARPOS()
; Purpose :
; Finds position to insert record into FITS header.
; Explanation :
; Finds the position to insert a record into a FITS header. Called from
; FXADDPAR.
; Use :
; Result = FXPARPOS(KEYWRD, IEND [, BEFORE=BEFORE ] [, AFTER=AFTER ])
; Inputs :
; KEYWRD = Array of eight-character keywords in header.
; IEND = Position of END keyword.
; Opt. Inputs :
; None.
; Outputs :
; Result of function is position to insert record.
; Opt. Outputs:
; None.
; Keywords :
; BEFORE = Keyword string name. The parameter will be placed before the
; location of this keyword. For example, if BEFORE='HISTORY'
; then the parameter will be placed before the first history
; location. This applies only when adding a new keyword;
; keywords already in the header are kept in the same position.
;
; AFTER = Same as BEFORE, but the parameter will be placed after the
; location of this keyword. This keyword takes precedence over
; BEFORE.
;
; If neither BEFORE or AFTER keywords are passed, then IEND is returned.
;
; Calls :
; None.
; Common :
; None.
; Restrictions:
; KEYWRD and IEND must be consistent with the relevant FITS header.
; Side effects:
; None.
; Category :
; Data Handling, I/O, FITS, Generic.
; Prev. Hist. :
; William Thompson, Jan 1992.
; Written :
; William Thompson, GSFC, January 1992.
; Modified :
; Version 1, William Thompson, GSFC, 12 April 1993.
; Incorporated into CDS library.
; Version :
; Version 1, 12 April 1993.
; Converted to IDL V5.0 W. Landsman September 1997
;:Private:
;-
FUNCTION eve_rwf_FXPARPOS, KEYWRD, IEND, BEFORE=BEFORE, AFTER=AFTER
;
ON_ERROR,2 ;Return to caller
;
; Check the number of parameters.
;
IF N_PARAMS() NE 2 THEN MESSAGE, $
'Required parameters are KEYWRD and IEND'
;
; If the AFTER keyword has been entered, then find the location.
;
IF N_ELEMENTS(AFTER) EQ 1 THEN BEGIN
KEY_AFTER = STRING(REPLICATE(32B,8))
STRPUT,KEY_AFTER,STRUPCASE(STRTRIM(AFTER,2)),0
ILOC = WHERE(KEYWRD EQ KEY_AFTER,NLOC)
IF NLOC GT 0 THEN RETURN, (MAX(ILOC)+1) < IEND
ENDIF
;
; If AFTER wasn't entered or found, and if the BEFORE keyword has been
; entered, then find the location.
;
IF N_ELEMENTS(BEFORE) EQ 1 THEN BEGIN
KEY_BEFORE = STRING(REPLICATE(32B,8))
STRPUT,KEY_BEFORE,STRUPCASE(STRTRIM(BEFORE,2)),0
ILOC = WHERE(KEYWRD EQ KEY_BEFORE,NLOC)
IF NLOC GT 0 THEN RETURN,ILOC[0]
ENDIF
;
; Otherwise, simply return IEND.
;
RETURN,IEND
END
;+
; NAME:
; FXADDPAR
; Purpose :
; Add or modify a parameter in a FITS header array.
; Explanation :
; This version of FXADDPAR will write string values longer than 68
; characters using the FITS continuation convention described at
; http://heasarc.gsfc.nasa.gov/docs/heasarc/ofwg/docs/ofwg_recomm/r13.html
; Use :
; FXADDPAR, HEADER, NAME, VALUE, COMMENT
; Inputs :
; HEADER = String array containing FITS header. The maximum string
; length must be equal to 80. If not defined, then FXADDPAR
; will create an empty FITS header array.
;
; NAME = Name of parameter. If NAME is already in the header the
; value and possibly comment fields are modified. Otherwise a
; new record is added to the header. If NAME is equal to
; either "COMMENT" or "HISTORY" then the value will be added to
; the record without replacement. In this case the comment
; parameter is ignored.
;
; VALUE = Value for parameter. The value expression must be of the
; correct type, e.g. integer, floating or string.
; String values of 'T' or 'F' are considered logical
; values unless the /NOLOGICAL keyword is set. If the value is
; a string and is "long" (more than 69 characters), then it
; may be continued over more than one line using the OGIP
; CONTINUE standard.
;
; Opt. Inputs :
; COMMENT = String field. The '/' is added by this routine. Added
; starting in position 31. If not supplied, or set equal to ''
; (the null string), then any previous comment field in the
; header for that keyword is retained (when found).
; Outputs :
; HEADER = Updated header array.
; Opt. Outputs:
; None.
; Keywords :
; BEFORE = Keyword string name. The parameter will be placed before the
; location of this keyword. For example, if BEFORE='HISTORY'
; then the parameter will be placed before the first history
; location. This applies only when adding a new keyword;
; keywords already in the header are kept in the same position.
;
; AFTER = Same as BEFORE, but the parameter will be placed after the
; location of this keyword. This keyword takes precedence over
; BEFORE.
;
; FORMAT = Specifies FORTRAN-like format for parameter, e.g. "F7.3". A
; scalar string should be used. For complex numbers the format
; should be defined so that it can be applied separately to the
; real and imaginary parts. If not supplied, then the IDL
; default formatting is used, except that double precision is
; given a format of G19.12.
;
; /NOCONTINUE = By default, FXADDPAR will break strings longer than 68
; characters into multiple lines using the continuation
; convention. If this keyword is set, then the line will
; instead be truncated to 68 characters. This was the default
; behaviour of FXADDPAR prior to December 1999.
;
; /NOLOGICAL = If set, then the values 'T' and 'F' are not interpreted as
; logical values, and are simply added without interpretation.
;
; ERRMSG = If defined and passed, then any error messages will be
; returned to the user in this parameter rather than
; depending on the MESSAGE routine in IDL, e.g.
;
; ERRMSG = ''
; FXADDPAR, ERRMSG=ERRMSG, ...
; IF ERRMSG NE '' THEN ...
;
; Calls :
; DETABIFY(), FXPAR(), FXPARPOS()
; Common :
; None.
; Restrictions:
; Warning -- Parameters and names are not checked against valid FITS
; parameter names, values and types.
;
; The required FITS keywords SIMPLE (or XTENSION), BITPIX, NAXIS, NAXIS1,
; NAXIS2, etc., must be entered in order. The actual values of these
; keywords are not checked for legality and consistency, however.
;
; Side effects:
; All HISTORY records are inserted in order at the end of the header.
;
; All COMMENT records are also inserted in order at the end of the
; header, but before the HISTORY records. The BEFORE and AFTER keywords
; can override this.
;
; All records with no keyword (blank) are inserted in order at the end of
; the header, but before the COMMENT and HISTORY records. The BEFORE and
; AFTER keywords can override this.
;
; All other records are inserted before any of the HISTORY, COMMENT, or
; "blank" records. The BEFORE and AFTER keywords can override this.
;
; String values longer than 68 characters will be split into multiple
; lines using the OGIP CONTINUE convention, unless the /NOCONTINUE keyword
; is set. For a description of the CONTINUE convention see
; http://fits.gsfc.nasa.gov/registry/continue_keyword.html
; Category :
; Data Handling, I/O, FITS, Generic.
; Prev. Hist. :
; William Thompson, Jan 1992, from SXADDPAR by D. Lindler and J. Isensee.
; Differences include:
;
; * LOCATION parameter replaced with keywords BEFORE and AFTER.
; * Support for COMMENT and "blank" FITS keywords.
; * Better support for standard FITS formatting of string and
; complex values.
; * Built-in knowledge of the proper position of required
; keywords in FITS (although not necessarily SDAS/Geis) primary
; headers, and in TABLE and BINTABLE extension headers.
;
; William Thompson, May 1992, fixed bug when extending length of header,
; and new record is COMMENT, HISTORY, or blank.
; Written :
; William Thompson, GSFC, January 1992.
; Modified :
; Version 1, William Thompson, GSFC, 12 April 1993.
; Incorporated into CDS library.
; Version 2, William Thompson, GSFC, 5 September 1997
; Fixed bug replacing strings that contain "/" character--it
; interpreted the following characters as a comment.
; Version 3, Craig Markwardt, GSFC, December 1997
; Allow long values to extend over multiple lines
; Version 4, D. Lindler, March 2000, modified to use capital E instead
; of a lower case e for exponential format.
; Version 4.1 W. Landsman April 2000, make user-supplied format uppercase
; Version 4.2 W. Landsman July 2002, positioning of EXTEND keyword
; Version 5, 23-April-2007, William Thompson, GSFC
; Version 6, 02-Aug-2007, WTT, bug fix for OGIP long lines
; Version 6.1, 10-Feb-2009, W. Landsman, increase default format precision
; Version 6.2 30-Sep-2009, W. Landsman, added /NOLOGICAL keyword
; Version :
; Version 6.2, 30-Sep-2009
;:Private:
;-
PRO eve_rwf_FXADDPAR, HEADER, NAME, VALUE, COMMENT, BEFORE=BEFORE, $
AFTER=AFTER, FORMAT=FORMAT, NOCONTINUE = NOCONTINUE, $
ERRMSG=ERRMSG, NOLOGICAL=NOLOGICAL
ON_ERROR,2 ;Return to caller
;
; Check the number of parameters.
;
IF N_PARAMS() LT 3 THEN BEGIN
MESSAGE = 'Syntax: FXADDPAR, HEADER, NAME, VALUE [, COMMENT ]'
GOTO, HANDLE_ERROR
ENDIF
;
; Define a blank line and the END line
;
ENDLINE = 'END' + STRING(REPLICATE(32B,77)) ;END line
BLANK = STRING(REPLICATE(32B,80)) ;BLANK line
;
; If no comment was passed, then use a null string.
;
IF N_PARAMS() LT 4 THEN COMMENT = ''
;
; Check the HEADER array.
;
N = N_ELEMENTS(HEADER) ;# of lines in FITS header
IF N EQ 0 THEN BEGIN ;header defined?
HEADER=STRARR(36) ;no, make it.
HEADER[0]=ENDLINE
N=36
ENDIF ELSE BEGIN
S = SIZE(HEADER) ;check for string type
IF (S[0] NE 1) OR (S[2] NE 7) THEN BEGIN
MESSAGE = 'FITS Header (first parameter) must be a ' + $
'string array'
GOTO, HANDLE_ERROR
ENDIF
ENDELSE
;
; Make sure NAME is 8 characters long
;
NN = STRING(REPLICATE(32B,8)) ;8 char name
STRPUT,NN,STRUPCASE(NAME) ;Insert name
;
; Check VALUE.
;
S = SIZE(VALUE) ;get type of value parameter
STYPE = S[S[0]+1]
IF S[0] NE 0 THEN BEGIN
MESSAGE = 'Keyword Value (third parameter) must be scalar'
GOTO, HANDLE_ERROR
END ELSE IF STYPE EQ 0 THEN BEGIN
MESSAGE = 'Keyword Value (third parameter) is not defined'
GOTO, HANDLE_ERROR
END ELSE IF STYPE EQ 8 THEN BEGIN
MESSAGE = 'Keyword Value (third parameter) cannot be structure'
GOTO, HANDLE_ERROR
ENDIF
;
; Extract first 8 characters of each line of header, and locate END line
;
KEYWRD = STRMID(HEADER,0,8) ;Header keywords
IEND = WHERE(KEYWRD EQ 'END ',NFOUND)
;
; If no END, then add it. Either put it after the last non-null string, or
; append it to the end.
;
IF NFOUND EQ 0 THEN BEGIN
II = WHERE(STRTRIM(HEADER) NE '',NFOUND)
II = MAX(II) + 1
IF (NFOUND EQ 0) OR (II EQ N_ELEMENTS(HEADER)) THEN $
HEADER = [HEADER,ENDLINE] ELSE HEADER[II] = ENDLINE
KEYWRD = STRMID(HEADER,0,8)
IEND = WHERE(KEYWRD EQ 'END ',NFOUND)
ENDIF
;
IEND = IEND[0] > 0 ;Make scalar
;
; History, comment and "blank" records are treated differently from the
; others. They are simply added to the header array whether there are any
; already there or not.
;
IF (NN EQ 'COMMENT ') OR (NN EQ 'HISTORY ') OR $
(NN EQ ' ') THEN BEGIN
;
; If the header array needs to grow, then expand it in increments of 36 lines.
;
IF IEND GE (N-1) THEN BEGIN
HEADER = [HEADER,REPLICATE(BLANK,36)]
N = N_ELEMENTS(HEADER)
ENDIF
;
; Format the record.
;
NEWLINE = BLANK
STRPUT,NEWLINE,NN+STRING(VALUE),0
;
; If a history record, then append to the record just before the end.
;
IF NN EQ 'HISTORY ' THEN BEGIN
HEADER[IEND] = NEWLINE ;add history rec.
HEADER[IEND+1]=ENDLINE ;move end up
;
; The comment record is placed immediately after the last previous comment
; record, or immediately before the first history record, unless overridden by
; either the BEFORE or AFTER keywords.
;
END ELSE IF NN EQ 'COMMENT ' THEN BEGIN
I = eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE=BEFORE)
IF I EQ IEND THEN I = $
eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER='COMMENT',$
BEFORE='HISTORY')
HEADER[I+1] = HEADER[I:N-2] ;move rest up
HEADER[I] = NEWLINE ;insert comment
;
; The "blank" record is placed immediately after the last previous "blank"
; record, or immediately before the first comment or history record, unless
; overridden by either the BEFORE or AFTER keywords.
;
END ELSE BEGIN
I = eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE=BEFORE)
IF I EQ IEND THEN I = $
eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER='',BEFORE='COMMENT')<$
eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER='',BEFORE='HISTORY')
HEADER[I+1] = HEADER[I:N-2] ;move rest up
HEADER[I] = NEWLINE ;insert "blank"
ENDELSE
RETURN
ENDIF ;history/comment/blank
;
; Find location to insert keyword. If the keyword is already in the header,
; then simply replace it. If no new comment is passed, then retain the old
; one.
;
IPOS = WHERE(KEYWRD EQ NN,NFOUND)
IF NFOUND GT 0 THEN BEGIN
I = IPOS[0]
IF COMMENT EQ '' THEN BEGIN
SLASH = STRPOS(HEADER[I],'/')
QUOTE = STRPOS(HEADER[I],"'")
IF (QUOTE GT 0) AND (QUOTE LT SLASH) THEN BEGIN
QUOTE = STRPOS(HEADER[I],"'",QUOTE+1)
IF QUOTE LT 0 THEN SLASH = -1 ELSE $
SLASH = STRPOS(HEADER[I],'/',QUOTE+1)
ENDIF
IF SLASH NE -1 THEN $
COMMENT = STRMID(HEADER[I],SLASH+1,80) ELSE $
COMMENT = STRING(REPLICATE(32B,80))
ENDIF
GOTO, REPLACE
ENDIF
;
; Start of section dealing with the positioning of required FITS keywords. If
; the keyword is SIMPLE, then it must be at the beginning.
;
IF NN EQ 'SIMPLE ' THEN BEGIN
I = 0
GOTO, INSERT
ENDIF
;
; In conforming extensions, if the keyword is XTENSION, then it must be at the
; beginning.
;
IF NN EQ 'XTENSION' THEN BEGIN
I = 0
GOTO, INSERT
ENDIF
;
; If the keyword is BITPIX, then it must follow the either SIMPLE or XTENSION
; keyword.
;
IF NN EQ 'BITPIX ' THEN BEGIN
IF (KEYWRD[0] NE 'SIMPLE ') AND $
(KEYWRD[0] NE 'XTENSION') THEN BEGIN
MESSAGE = 'Header must start with either SIMPLE or XTENSION'
GOTO, HANDLE_ERROR
ENDIF
I = 1
GOTO, INSERT
ENDIF
;
; If the keyword is NAXIS, then it must follow the BITPIX keyword.
;
IF NN EQ 'NAXIS ' THEN BEGIN
IF KEYWRD[1] NE 'BITPIX ' THEN BEGIN
MESSAGE = 'Required BITPIX keyword not found'
GOTO, HANDLE_ERROR
ENDIF
I = 2
GOTO, INSERT
ENDIF
;
; If the keyword is NAXIS1, then it must follow the NAXIS keyword.
;
IF NN EQ 'NAXIS1 ' THEN BEGIN
IF KEYWRD[2] NE 'NAXIS ' THEN BEGIN
MESSAGE = 'Required NAXIS keyword not found'
GOTO, HANDLE_ERROR
ENDIF
I = 3
GOTO, INSERT
ENDIF
;
; If the keyword is NAXIS<n>, then it must follow the NAXIS<n-1> keyword.
;
IF STRMID(NN,0,5) EQ 'NAXIS' THEN BEGIN
NUM_AXIS = FIX(STRMID(NN,5,3))
PREV = STRING(REPLICATE(32B,8)) ;Format NAXIS<n-1>
STRPUT,PREV,'NAXIS',0 ;Insert NAXIS
STRPUT,PREV,STRTRIM(NUM_AXIS-1,2),5 ;Insert <n-1>
IF KEYWRD[NUM_AXIS+1] NE PREV THEN BEGIN
MESSAGE = 'Required '+PREV+' keyword not found'
GOTO, HANDLE_ERROR
ENDIF
I = NUM_AXIS + 2
GOTO, INSERT
ENDIF
;
; If the keyword is EXTEND, then it must follow the last NAXIS* keyword.
;
IF NN EQ 'EXTEND ' THEN BEGIN
IF KEYWRD[2] NE 'NAXIS ' THEN BEGIN
MESSAGE = 'Required NAXIS keyword not found'
GOTO, HANDLE_ERROR
ENDIF
FOR I = 3, N-2 DO $
IF STRMID(KEYWRD[I],0,5) NE 'NAXIS' THEN GOTO, INSERT
ENDIF
;
; If the first keyword is XTENSION, and has the value of either 'TABLE' or
; 'BINTABLE', then there are some additional required keywords.
;
IF KEYWRD[0] EQ 'XTENSION' THEN BEGIN
XTEN = eve_rwf_FXPAR(HEADER,'XTENSION')
IF (XTEN EQ 'TABLE ') OR (XTEN EQ 'BINTABLE') THEN BEGIN
;
; If the keyword is PCOUNT, then it must follow the NAXIS2 keyword.
;
IF NN EQ 'PCOUNT ' THEN BEGIN
IF KEYWRD[4] NE 'NAXIS2 ' THEN BEGIN
MESSAGE = 'Required NAXIS2 keyword not found'
GOTO, HANDLE_ERROR
ENDIF
I = 5
GOTO, INSERT
ENDIF
;
; If the keyword is GCOUNT, then it must follow the PCOUNT keyword.
;
IF NN EQ 'GCOUNT ' THEN BEGIN
IF KEYWRD[5] NE 'PCOUNT ' THEN BEGIN
MESSAGE = 'Required PCOUNT keyword not found'
GOTO, HANDLE_ERROR
ENDIF
I = 6
GOTO, INSERT
ENDIF
;
; If the keyword is TFIELDS, then it must follow the GCOUNT keyword.
;
IF NN EQ 'TFIELDS ' THEN BEGIN
IF KEYWRD[6] NE 'GCOUNT ' THEN BEGIN
MESSAGE = 'Required GCOUNT keyword not found'
GOTO, HANDLE_ERROR
ENDIF
I = 7
GOTO, INSERT
ENDIF
ENDIF
ENDIF
;
; At this point the location has not been determined, so a new line is added
; at the end of the FITS header, but before any blank, COMMENT, or HISTORY
; keywords, unless overridden by the BEFORE or AFTER keywords.
;
I = eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE=BEFORE)
IF I EQ IEND THEN I = $
eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE='') < $
eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE='COMMENT') < $
eve_rwf_FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE='HISTORY')
;
; A new line needs to be added. First check to see if the length of the
; header array needs to be extended. Then insert a blank record at the proper
; place.
;
INSERT:
IF IEND EQ (N-1) THEN BEGIN
HEADER = [HEADER,REPLICATE(BLANK,36)]
N = N_ELEMENTS(HEADER)
ENDIF
HEADER[I+1] = HEADER[I:N-2]
HEADER[I] = BLANK
IEND = IEND + 1 ; CM 24 Sep 1997
;
; Now put value into keyword at line I.
;
REPLACE:
H=BLANK ;80 blanks
STRPUT,H,NN+'= ' ;insert name and =.
APOST = "'" ;quote (apostrophe) character
TYPE = SIZE(VALUE) ;get type of value parameter
;
; Store the value depending on the data type. If a character string, first
; check to see if it is one of the logical values "T" (true) or "F" (false).
;
IF TYPE[1] EQ 7 THEN BEGIN ;which type?
UPVAL = STRUPCASE(VALUE) ;force upper case.
IF ~KEYWORD_SET(NOLOGICAL) $
&& ((UPVAL EQ 'T') OR (UPVAL EQ 'F')) THEN BEGIN
STRPUT,H,UPVAL,29 ;insert logical value.
;
; Otherwise, remove any tabs, and check for any apostrophes in the string.
;
END ELSE BEGIN
VAL = eve_rwf_detabify(VALUE)
NEXT_CHAR = 0
REPEAT BEGIN
AP = STRPOS(VAL,"'",NEXT_CHAR)
IF AP GE 66 THEN BEGIN
VAL = STRMID(VAL,0,66)
END ELSE IF AP GE 0 THEN BEGIN
VAL = STRMID(VAL,0,AP+1) + APOST + $
STRMID(VAL,AP+1,80)
NEXT_CHAR = AP + 2
ENDIF
ENDREP UNTIL AP LT 0
;
; If a long string, then add the comment as soon as possible.
;
; CM 24 Sep 1997
; Separate parameter if it needs to be CONTINUEd.
;
IF NOT KEYWORD_SET(NOCONTINUE) THEN $
eve_rwf_FXADDPAR_CONTPAR, VAL, CVAL ELSE $
CVAL = STRMID(VAL,0,68)
K = I + 1
;; See how many CONTINUE lines there already are
WHILE K LT IEND DO BEGIN
IF STRMID(HEADER[K],0,8) NE 'CONTINUE' THEN $
GOTO, DONE_CHECK_CONT
K = K + 1
ENDWHILE
DONE_CHECK_CONT:
NOLDCONT = K - I - 1
NNEWCONT = N_ELEMENTS(CVAL) - 1
;; Insert new lines if needed
IF NNEWCONT GT NOLDCONT THEN BEGIN
INS = NNEWCONT - NOLDCONT
WHILE IEND+INS GE N DO BEGIN
HEADER = [HEADER, REPLICATE(BLANK,36)]
N = N_ELEMENTS(HEADER)
ENDWHILE
ENDIF
;; Shift the old lines properly
IF NNEWCONT NE NOLDCONT THEN $
HEADER[I+NNEWCONT+1] = HEADER[I+NOLDCONT+1:IEND]
IEND = IEND + NNEWCONT - NOLDCONT
;; Blank out any lines at the end if needed
IF NNEWCONT LT NOLDCONT THEN BEGIN
DEL = NOLDCONT - NNEWCONT
HEADER[IEND+1:IEND+DEL] = REPLICATE('', DEL)
ENDIF
IF STRLEN(CVAL[0]) GT 18 THEN BEGIN
STRPUT,H,APOST+STRMID(CVAL[0],0,68)+APOST+ $
' /'+COMMENT,10
HEADER[I]=H
; There might be a continuation of this string. CVAL would contain
; more than one element if that is so.
;; Add new continuation lines
IF N_ELEMENTS(CVAL) GT 1 THEN BEGIN
HEADER[I+1] = CVAL[1:*]
;; Header state is now clean, so add
;; warning to header
eve_rwf_FXADDPAR_CONTWARN, HEADER, NAME
ENDIF
DONE_CONT:
RETURN
;
; If a short string, then pad out to at least eight characters.
;
END ELSE BEGIN
STRPUT,H,APOST+CVAL[0],10
STRPUT,H,APOST,11+(STRLEN(CVAL[0])>8)
ENDELSE
ENDELSE
;
; If complex, then format the real and imaginary parts, and add the comment
; beginning in column 51.
;
END ELSE IF TYPE[1] EQ 6 THEN BEGIN
IF N_ELEMENTS(FORMAT) EQ 1 THEN BEGIN ;use format keyword
VR = STRING(FLOAT(VALUE), '('+STRUPCASE(FORMAT)+')')
VI = STRING(IMAGINARY(VALUE),'('+STRUPCASE(FORMAT)+')')
END ELSE BEGIN
VR = STRTRIM(FLOAT(VALUE),2)
VI = STRTRIM(IMAGINARY(VALUE),2)
ENDELSE
SR = STRLEN(VR) & STRPUT,H,VR,(30-SR)>10
SI = STRLEN(VI) & STRPUT,H,VI,(50-SI)>30
STRPUT,H,' /'+COMMENT,50
HEADER[I] = H
RETURN
;
; If not complex or a string, then format according to either the FORMAT
; keyword, or the default for that datatype.
;
END ELSE BEGIN
IF (N_ELEMENTS(FORMAT) EQ 1) THEN $ ;use format keyword
V = STRING(VALUE,'('+STRUPCASE(FORMAT)+')' ) ELSE BEGIN
IF TYPE[1] EQ 5 THEN $
V = STRING(VALUE,FORMAT='(G19.12)') ELSE $
V = STRTRIM(strupcase(VALUE),2) ;default format
ENDELSE
S = STRLEN(V) ;right justify
STRPUT,H,V,(30-S)>10 ;insert
ENDELSE
;
; Add the comment, and store the completed line in the header.
;
STRPUT,H,' /',30 ;add ' /'
STRPUT,H,COMMENT,32 ;add comment
HEADER[I]=H ;save line
;
ERRMSG = ''
RETURN
;
; Error handling point.
;
HANDLE_ERROR:
IF ARG_PRESENT(ERRMSG) THEN ERRMSG = 'FXADDPAR: ' + MESSAGE $
ELSE MESSAGE, MESSAGE
RETURN
END
;+
; NAME:
; FXPAR()
; PURPOSE:
; Obtain the value of a parameter in a FITS header.
; EXPLANATION:
; The first 8 chacters of each element of HDR are searched for a match to
; NAME. If the keyword is one of those allowed to take multiple values
; ("HISTORY", "COMMENT", or " " (blank)), then the value is taken
; as the next 72 characters. Otherwise, it is assumed that the next
; character is "=", and the value (and optional comment) is then parsed
; from the last 71 characters. An error occurs if there is no parameter
; with the given name.
;
; If the value is too long for one line, it may be continued on to the
; the next input card, using the CONTINUE Long String Keyword convention.
; For more info, http://fits.gsfc.nasa.gov/registry/continue_keyword.html
;
;
; Complex numbers are recognized as two numbers separated by one or more
; space characters.
;
; If a numeric value has no decimal point (or E or D) it is returned as
; type LONG. If it contains more than 8 numerals, or contains the
; character 'D', then it is returned as type DOUBLE. Otherwise it is
; returned as type FLOAT. If an integer is too large to be stored as
; type LONG, then it is returned as DOUBLE.
;
; CALLING SEQUENCE:
; Result = FXPAR( HDR, NAME [, ABORT, COUNT=, COMMENT=, /NOCONTINUE ] )
;
; Result = FXPAR(HEADER,'DATE') ;Finds the value of DATE
; Result = FXPAR(HEADER,'NAXIS*') ;Returns array dimensions as
; ;vector
; REQUIRED INPUTS:
; HDR = FITS header string array (e.g. as returned by FXREAD). Each
; element should have a length of 80 characters
; NAME = String name of the parameter to return. If NAME is of the
; form 'keyword*' then an array is returned containing values
; of keywordN where N is an integer. The value of keywordN
; will be placed in RESULT(N-1). The data type of RESULT will
; be the type of the first valid match of keywordN
; found, unless DATATYPE is given.
; OPTIONAL INPUT:
; ABORT = String specifying that FXPAR should do a RETALL if a
; parameter is not found. ABORT should contain a string to be
; printed if the keyword parameter is not found. If not
; supplied, FXPAR will return with a negative !err if a keyword
; is not found.
; DATATYPE = A scalar value, indicating the type of vector
; data. All keywords will be cast to this type.
; Default: based on first keyword.
; Example: DATATYPE=0.0D (cast data to double precision)
; START = A best-guess starting position of the sought-after
; keyword in the header. If specified, then FXPAR
; first searches for scalar keywords in the header in
; the index range bounded by START-PRECHECK and
; START+POSTCHECK. This can speed up keyword searches
; in large headers. If the keyword is not found, then
; FXPAR searches the entire header.
;
; If not specified then the entire header is searched.
; Searches of the form 'keyword*' also search the
; entire header and ignore START.
;
; Upon return START is changed to be the position of
; the newly found keyword. Thus the best way to
; search for a series of keywords is to search for
; them in the order they appear in the header like
; this:
;
; START = 0L
; P1 = FXPAR('P1', START=START)
; P2 = FXPAR('P2', START=START)
; PRECHECK = If START is specified, then PRECHECK is the number
; of keywords preceding START to be searched.
; Default: 5
; POSTCHECK = If START is specified, then POSTCHECK is the number
; of keywords after START to be searched.
; Default: 20
; OUTPUT:
; The returned value of the function is the value(s) associated with the
; requested keyword in the header array.
;
; If the parameter is complex, double precision, floating point, long or
; string, then the result is of that type. Apostrophes are stripped from
; strings. If the parameter is logical, 1 is returned for T, and 0 is
; returned for F.
;
; If NAME was of form 'keyword*' then a vector of values are returned.
;
; OPTIONAL INPUT KEYWORDS:
; /NOCONTINUE = If set, then continuation lines will not be read, even
; if present in the header
; OPTIONAL OUTPUT KEYWORD:
; COUNT = Optional keyword to return a value equal to the number of
; parameters found by FXPAR.
; COMMENTS= Array of comments associated with the returned values.
;
; PROCEDURE CALLS:
; GETTOK(), VALID_NUM
; SIDE EFFECTS:
;
; The system variable !err is set to -1 if parameter not found, 0 for a
; scalar value returned. If a vector is returned it is set to the number
; of keyword matches found.
;
; If a keyword occurs more than once in a header, a warning is given,
; and the first occurence is used. However, if the keyword is "HISTORY",
; "COMMENT", or " " (blank), then multiple values are returned.
;
; NOTES:
; The functions SXPAR() and FXPAR() are nearly identical, although
; FXPAR() has slightly more sophisticated parsing. There is no
; particular reason for having two nearly identical procedures, but
; both are too widely used to drop either one.
;
; REVISION HISTORY:
; Version 1, William Thompson, GSFC, 12 April 1993.
; Adapted from SXPAR
; Version 2, William Thompson, GSFC, 14 October 1994
; Modified to use VALID_NUM instead of STRNUMBER. Inserted
; additional call to VALID_NUM to trap cases where character
; strings did not contain quotation marks.
; Version 3, William Thompson, GSFC, 22 December 1994
; Fixed bug with blank keywords, following suggestion by Wayne
; Landsman.
; Version 4, Mons Morrison, LMSAL, 9-Jan-98
; Made non-trailing ' for string tag just be a warning (not
; a fatal error). It was needed because "sxaddpar" had an
; error which did not write tags properly for long strings
; (over 68 characters)
; Version 5, Wayne Landsman GSFC, 29 May 1998
; Fixed potential problem with overflow of LONG values
; Version 6, Craig Markwardt, GSFC, 28 Jan 1998,
; Added CONTINUE parsing
; Version 7, Craig Markwardt, GSFC, 18 Nov 1999,
; Added START, PRE/POSTCHECK keywords for better
; performance
; Version 8, Craig Markwardt, GSFC, 08 Oct 2003,
; Added DATATYPE keyword to cast vector keywords type
; Version 9, Paul Hick, 22 Oct 2003, Corrected bug (NHEADER-1)
;:Private:
;-
FUNCTION eve_rwf_FXPAR, HDR, NAME, ABORT, COUNT=MATCHES, COMMENT=COMMENTS, $
START=START, PRECHECK=PRECHECK, POSTCHECK=POSTCHECK, $
NOCONTINUE = NOCONTINUE, $
DATATYPE=DATATYPE
;------------------------------------------------------------------------------
;
; Check the number of parameters.
;
IF N_PARAMS() LT 2 THEN BEGIN
PRINT,'Syntax: result = FXPAR( HDR, NAME [, ABORT ])'
RETURN, -1
ENDIF
;
; Determine the abort condition.
;
VALUE = 0
IF N_PARAMS() LE 2 THEN BEGIN
ABORT_RETURN = 0
ABORT = 'FITS Header'
END ELSE ABORT_RETURN = 1
IF ABORT_RETURN THEN ON_ERROR,1 ELSE ON_ERROR,2
;
; Check for valid header. Check header for proper attributes.
;
S = SIZE(HDR)
IF ( S[0] NE 1 ) OR ( S[2] NE 7 ) THEN $
MESSAGE,'FITS Header (first parameter) must be a string array'
;
; Convert the selected keyword NAME to uppercase.
;
NAM = STRTRIM( STRUPCASE(NAME) )
;
; Determine if NAME is of form 'keyword*'. If so, then strip off the '*', and
; set the VECTOR flag. One must consider the possibility that NAM is an empty
; string.
;
NAMELENGTH1 = (STRLEN(NAM) - 1) > 1
IF STRPOS( NAM, '*' ) EQ NAMELENGTH1 THEN BEGIN
NAM = STRMID( NAM, 0, NAMELENGTH1)
VECTOR = 1 ;Flag for vector output
NAME_LENGTH = STRLEN(NAM) ;Length of name
NUM_LENGTH = 8 - NAME_LENGTH ;Max length of number portion
IF NUM_LENGTH LE 0 THEN MESSAGE, $
'Keyword length must be 8 characters or less'
;
; Otherwise, extend NAME with blanks to eight characters.
;
ENDIF ELSE BEGIN
WHILE STRLEN(NAM) LT 8 DO NAM = NAM + ' '
VECTOR = 0
ENDELSE
;
; If of the form 'keyword*', then find all instances of 'keyword' followed by
; a number. Store the positions of the located keywords in NFOUND, and the
; value of the number field in NUMBER.
;
IF N_ELEMENTS(START) EQ 0 THEN START = -1L
START = LONG(START[0])
IF NOT VECTOR AND START GE 0 THEN BEGIN
IF N_ELEMENTS(PRECHECK) EQ 0 THEN PRECHECK = 5
IF N_ELEMENTS(POSTCHECK) EQ 0 THEN POSTCHECK = 20
NHEADER = N_ELEMENTS(HDR)
MN = (START - PRECHECK) > 0
MX = (START + POSTCHECK) < (NHEADER-1) ;Corrected bug
KEYWORD = STRMID(HDR[MN:MX], 0, 8)
ENDIF ELSE BEGIN
RESTART:
START = -1L
KEYWORD = STRMID( HDR, 0, 8)
ENDELSE
IF VECTOR THEN BEGIN
NFOUND = WHERE(STRPOS(KEYWORD,NAM) GE 0, MATCHES)
IF ( MATCHES GT 0 ) THEN BEGIN
NUMST= STRMID(HDR[NFOUND], NAME_LENGTH, NUM_LENGTH)
NUMBER = INTARR(MATCHES)-1
FOR I = 0, MATCHES-1 DO $
IF eve_rwf_valid_num( NUMST[I], NUM) THEN NUMBER[I] = NUM
IGOOD = WHERE(NUMBER GE 0, MATCHES)
IF MATCHES GT 0 THEN BEGIN
NFOUND = NFOUND[IGOOD]
NUMBER = NUMBER[IGOOD]
ENDIF
ENDIF
;
; Otherwise, find all the instances of the requested keyword. If more than
; one is found, and NAME is not one of the special cases, then print an error
; message.
;
ENDIF ELSE BEGIN
NFOUND = WHERE(KEYWORD EQ NAM, MATCHES)
IF MATCHES EQ 0 AND START GE 0 THEN GOTO, RESTART
IF START GE 0 THEN NFOUND = NFOUND + MN
IF (MATCHES GT 1) AND (NAM NE 'HISTORY ') AND $
(NAM NE 'COMMENT ') AND (NAM NE '') THEN $
MESSAGE,/INFORMATIONAL, 'WARNING- Keyword ' + $
NAM + 'located more than once in ' + ABORT
IF (MATCHES GT 0) THEN START = NFOUND[MATCHES-1]
ENDELSE
;
; Extract the parameter field from the specified header lines. If one of the
; special cases, then done.
;
IF MATCHES GT 0 THEN BEGIN
LINE = HDR[NFOUND]
SVALUE = STRTRIM( STRMID(LINE,9,71),2)
IF (NAM EQ 'HISTORY ') OR (NAM EQ 'COMMENT ') OR $
(NAM EQ ' ') THEN BEGIN
VALUE = STRTRIM( STRMID(LINE,8,72),2)
COMMENTS = STRARR(N_ELEMENTS(VALUE))
;
; Otherwise, test to see if the parameter contains a string, signalled by
; beginning with a single quote character (') (apostrophe).
;
END ELSE FOR I = 0,MATCHES-1 DO BEGIN
IF ( STRMID(SVALUE[I],0,1) EQ "'" ) THEN BEGIN
TEST = STRMID( SVALUE[I],1,STRLEN( SVALUE[I] )-1)
NEXT_CHAR = 0
OFF = 0
VALUE = ''
;
; Find the next apostrophe.
;
NEXT_APOST:
ENDAP = STRPOS(TEST, "'", NEXT_CHAR)
IF ENDAP LT 0 THEN MESSAGE, $
'WARNING: Value of '+NAME+' invalid in '+ABORT+ " (no trailing ')", /info
VALUE = VALUE + STRMID( TEST, NEXT_CHAR, ENDAP-NEXT_CHAR )
;
; Test to see if the next character is also an apostrophe. If so, then the
; string isn't completed yet. Apostrophes in the text string are signalled as
; two apostrophes in a row.
;
IF STRMID( TEST, ENDAP+1, 1) EQ "'" THEN BEGIN
VALUE = VALUE + "'"
NEXT_CHAR = ENDAP+2
GOTO, NEXT_APOST
ENDIF
;
; Extract the comment, if any.
;
SLASH = STRPOS(TEST, "/", ENDAP)
IF SLASH LT 0 THEN COMMENT = '' ELSE $
COMMENT = STRMID(TEST, SLASH+1, STRLEN(TEST)-SLASH-1)
;
; CM 19 Sep 1997
; This is a string that could be continued on the next line. Check this
; possibility with the following four criteria: *1) Ends with '&'
; (2) Next line is CONTINUE (3) LONGSTRN keyword is present (recursive call to
; FXPAR) 4. /NOCONTINE is not set
IF NOT KEYWORD_SET(NOCONTINUE) THEN BEGIN
OFF = OFF + 1
VAL = STRTRIM(VALUE,2)
IF (STRLEN(VAL) GT 0) AND $
(STRMID(VAL, STRLEN(VAL)-1, 1) EQ '&') AND $
(STRMID(HDR[NFOUND[I]+OFF],0,8) EQ 'CONTINUE') THEN BEGIN
IF (SIZE(eve_rwf_FXPAR(HDR, 'LONGSTRN',/NOCONTINUE)))[1] EQ 7 THEN BEGIN
VALUE = STRMID(VAL, 0, STRLEN(VAL)-1)
TEST = HDR[NFOUND[I]+OFF]
TEST = STRMID(TEST, 8, STRLEN(TEST)-8)
TEST = STRTRIM(TEST, 2)
IF STRMID(TEST, 0, 1) NE "'" THEN MESSAGE, $
'ERROR: Invalidly CONTINUEd string in '+ABORT
NEXT_CHAR = 1
GOTO, NEXT_APOST
ENDIF
ENDIF
ENDIF
;
; If not a string, then separate the parameter field from the comment field.
;
ENDIF ELSE BEGIN
TEST = SVALUE[I]
SLASH = STRPOS(TEST, "/")
IF SLASH GT 0 THEN BEGIN
COMMENT = STRMID(TEST, SLASH+1, STRLEN(TEST)-SLASH-1)
TEST = STRMID(TEST, 0, SLASH)
END ELSE COMMENT = ''
;
; Find the first word in TEST. Is it a logical value ('T' or 'F')?
;
TEST2 = TEST
VALUE = eve_rwf_gettok(TEST2,' ')
TEST2 = STRTRIM(TEST2,2)
IF ( VALUE EQ 'T' ) THEN BEGIN
VALUE = 1
END ELSE IF ( VALUE EQ 'F' ) THEN BEGIN
VALUE = 0
END ELSE BEGIN
;
; Test to see if a complex number. It's a complex number if the value and the
; next word, if any, both are valid numbers.
;
IF STRLEN(TEST2) EQ 0 THEN GOTO, NOT_COMPLEX
VALUE2 = eve_rwf_gettok(TEST2,' ')
IF eve_rwf_valid_num(VALUE,VAL1) AND eve_rwf_valid_num(VALUE2,VAL2) $
THEN BEGIN
VALUE = COMPLEX(VAL1,VAL2)
GOTO, GOT_VALUE
ENDIF
;
; Not a complex number. Decide if it is a floating point, double precision,
; or integer number. If an error occurs, then a string value is returned.
; If the integer is not within the range of a valid long value, then it will
; be converted to a double.
;
NOT_COMPLEX:
ON_IOERROR, GOT_VALUE
VALUE = TEST
IF NOT eve_rwf_valid_num(VALUE) THEN GOTO, GOT_VALUE
IF (STRPOS(VALUE,'.') GE 0) OR (STRPOS(VALUE,'E') $
GE 0) OR (STRPOS(VALUE,'D') GE 0) THEN BEGIN
IF ( STRPOS(VALUE,'D') GT 0 ) OR $
( STRLEN(VALUE) GE 8 ) THEN BEGIN
VALUE = DOUBLE(VALUE)
END ELSE VALUE = FLOAT(VALUE)
ENDIF ELSE BEGIN
LMAX = 2.0D^31 - 1.0D
LMIN = -2.0D^31 ;Typo fixed Feb 2010
VALUE = DOUBLE(VALUE)
if (VALUE GE LMIN) and (VALUE LE LMAX) THEN $
VALUE = LONG(VALUE)
ENDELSE
;
GOT_VALUE:
ON_IOERROR, NULL
ENDELSE
ENDELSE ; if string
;
; Add to vector if required.
;
IF VECTOR THEN BEGIN
MAXNUM = MAX(NUMBER)
IF ( I EQ 0 ) THEN BEGIN
IF N_ELEMENTS(DATATYPE) EQ 0 THEN BEGIN
;; Data type determined from keyword
SZ_VALUE = SIZE(VALUE)
ENDIF ELSE BEGIN
;; Data type requested by user
SZ_VALUE = SIZE(DATATYPE[0])
ENDELSE
RESULT = MAKE_ARRAY( MAXNUM, TYPE=SZ_VALUE[1])
COMMENTS = STRARR(MAXNUM)
ENDIF
RESULT[ NUMBER[I]-1 ] = VALUE
COMMENTS[ NUMBER[I]-1 ] = COMMENT
ENDIF ELSE BEGIN
COMMENTS = COMMENT
ENDELSE
ENDFOR
;
; Set the value of !ERR for the number of matches for vectors, or simply 0
; otherwise.
;
IF VECTOR THEN BEGIN
!ERR = MATCHES
RETURN, RESULT
ENDIF ELSE !ERR = 0
;
; Error point for keyword not found.
;
ENDIF ELSE BEGIN
IF ABORT_RETURN THEN MESSAGE,'Keyword '+NAM+' not found in '+ABORT
!ERR = -1
ENDELSE
;
RETURN, VALUE
END
;+
; NAME:
; DETABIFY
; PURPOSE:
; Replaces tabs in character strings with appropriate number of spaces
; EXPLANATION:
; The number of space characters inserted is calculated to space
; out to the next effective tab stop, each of which is eight characters
; apart.
;
; CALLING SEQUENCE:
; Result = DETABIFY( CHAR_STR )
;
; INPUT PARAMETERS:
; CHAR_STR = Character string variable (or array) to remove tabs from.
;
; OUTPUT:
; Result of function is CHAR_STR with tabs replaced by spaces.
;
; RESTRICTIONS:
; CHAR_STR must be a character string variable.
;
; MODIFICATION HISTORY:
; William Thompson, Feb. 1992.
; Converted to IDL V5.0 W. Landsman September 1997
;:Private:
;-
FUNCTION eve_rwf_DETABIFY, CHAR_STR
;
ON_ERROR, 2
;
; Check the number of parameters.
;
IF N_PARAMS() NE 1 THEN MESSAGE,'Syntax: Result = DETABIFY(CHAR_STR)'
;
; Make sure CHAR_STR is of type string.
;
SZ = SIZE(CHAR_STR)
IF SZ[SZ[0]+1] NE 7 THEN BEGIN
MESSAGE,/INFORMATIONAL,'CHAR_STR must be of type string'
RETURN, CHAR_STR
ENDIF
;
; Step through each element of CHAR_STR.
;
STR = CHAR_STR
FOR I = 0,N_ELEMENTS(STR)-1 DO BEGIN
;
; Keep looking for tabs until there aren't any more.
;
REPEAT BEGIN
TAB = STRPOS(STR[I],STRING(9B))
IF TAB GE 0 THEN BEGIN
NBLANK = 8 - (TAB MOD 8)
STR[I] = STRMID(STR[I],0,TAB) + $
STRING(REPLICATE(32B,NBLANK)) + $
STRMID(STR[I],TAB+1,STRLEN(STR[I])-TAB-1)
ENDIF
ENDREP UNTIL TAB LT 0
ENDFOR
;
RETURN, STR
END
;+
; NAME:
; GETTOK
; PURPOSE:
; Retrieve the first part of a (vector) string up to a specified character
; EXPLANATION:
; GET TOKen - Retrieve first part of string until the character char
; is encountered.
;
; CALLING SEQUENCE:
; token = gettok( st, char, [ /EXACT, /NOTRIM ] )
;
; INPUT:
; char - character separating tokens, scalar string
;
; INPUT-OUTPUT:
; st - string to get token from (on output token is removed unless
; /NOTRIM is set), scalar or vector
;
; OUTPUT:
; token - extracted string value is returned, same dimensions as st
; OPTIONAL INPUT KEYWORD:
; /EXACT - The default behaviour of GETTOK is to remove any leading
; blanks and (if the token is a blank) convert tabs to blanks.
; Set the /EXACT keyword to skip these steps and leave the
; input string unchanged before searching for the character
; tokens.
;
; /NOTRIM - if set, then the input string is left unaltered
; EXAMPLE:
; If ST is ['abc=999','x=3.4234'] then gettok(ST,'=') would return
; ['abc','x'] and ST would be left as ['999','3.4234']
;
; PROCEDURE CALLS:
; REPCHR()
; HISTORY
; version 1 by D. Lindler APR,86
; Remove leading blanks W. Landsman (from JKF) Aug. 1991
; V5.3 version, accept vector input W. Landsman February 2000
; Slightly faster implementation W. Landsman February 2001
; Added EXACT keyword W. Landsman March 2004
; Assume since V5.4, Use COMPLEMENT keyword to WHERE W. Landsman Apr 2006
; Added NOTRIM keyword W. L. March 2011
;:Private:
;-
function eve_rwf_gettok,st,char, exact=exact, notrim=notrim
;----------------------------------------------------------------------
On_error,2 ;Return to caller
compile_opt idl2
if N_params() LT 2 then begin
print,'Syntax - token = eve_rwf_gettok( st, char, [ /EXACT, /NOTRIM] )'
return,-1
endif
; if char is a blank treat tabs as blanks
if ~keyword_set(exact) then begin
st = strtrim(st,1) ;Remove leading blanks and tabs
if char EQ ' ' then begin
tab = string(9b)
if max(strpos(st,tab)) GE 0 then st = eve_rwf_repchr(st,tab,' ')
endif
endif
token = st
; find character in string
pos = strpos(st,char)
test = pos EQ -1
bad = where(test, Nbad, Complement = good, Ncomplement=Ngood)
if Nbad GT 0 && ~keyword_set(notrim) then st[bad] = ''
; extract token
if Ngood GT 0 then begin
stg = st[good]
pos = reform( pos[good], 1, Ngood )
token[good] = strmid(stg,0,pos)
if ~keyword_set(notrim) then st[good] = strmid(stg,pos+1)
endif
; Return the result.
return,token
end
;+
; NAME:
; MATCH
; PURPOSE:
; Routine to match values in two vectors.
;
; CALLING SEQUENCE:
; match, a, b, suba, subb, [ COUNT =, /SORT, EPSILON = ]
;
; INPUTS:
; a,b - two vectors to match elements, numeric or string data types
;
; OUTPUTS:
; suba - subscripts of elements in vector a with a match
; in vector b
; subb - subscripts of the positions of the elements in
; vector b with matchs in vector a.
;
; suba and subb are ordered such that a[suba] equals b[subb]
;
; OPTIONAL INPUT KEYWORD:
; /SORT - By default, MATCH uses two different algorithm: (1) the
; /REVERSE_INDICES keyword to HISTOGRAM is used for integer data,
; while (2) a sorting algorithm is used for non-integer data. The
; histogram algorithm is usually faster, except when the input
; vectors are sparse and contain very large numbers, possibly
; causing memory problems. Use the /SORT keyword to always use
; the sort algorithm.
; epsilon - if values are within epsilon, they are considered equal. Used only
; only for non-integer matching. Note that input vectors should
; be unique to within epsilon to provide one-to-one mapping..
; Default=0.
;
; OPTIONAL KEYWORD OUTPUT:
; COUNT - set to the number of matches, integer scalar
;
; SIDE EFFECTS:
; The obsolete system variable !ERR is set to the number of matches;
; however, the use !ERR is deprecated in favor of the COUNT keyword
;
; RESTRICTIONS:
; The vectors a and b should not have duplicate values within them.
; You can use rem_dup function to remove duplicate values
; in a vector
;
; EXAMPLE:
; If a = [3,5,7,9,11] & b = [5,6,7,8,9,10]
; then
; IDL> match, a, b, suba, subb, COUNT = count
;
; will give suba = [1,2,3], subb = [0,2,4], COUNT = 3
; and a[suba] = b[subb] = [5,7,9]
;
;
; METHOD:
; For non-integer data types, the two input vectors are combined and
; sorted and the consecutive equal elements are identified. For integer
; data types, the /REVERSE_INDICES keyword to HISTOGRAM of each array
; is used to identify where the two arrays have elements in common.
; HISTORY:
; D. Lindler Mar. 1986.
; Fixed "indgen" call for very large arrays W. Landsman Sep 1991
; Added COUNT keyword W. Landsman Sep. 1992
; Fixed case where single element array supplied W. Landsman Aug 95
; Use a HISTOGRAM algorithm for integer vector inputs for improved
; performance W. Landsman March 2000
; Work again for strings W. Landsman April 2000
; Use size(/type) W. Landsman December 2002
; Work for scalar integer input W. Landsman June 2003
; Assume since V5.4, use COMPLEMENT to WHERE() W. Landsman Apr 2006
; Added epsilon keyword Kim Tolbert March 14, 2008
;:Private:
;-
pro eve_rwf_match, a, b, suba, subb, COUNT = count, SORT = sort, epsilon=epsilon
;-------------------------------------------------------------------------
On_error,2
compile_opt idl2
if N_elements(epsilon) EQ 0 then epsilon = 0
if N_params() LT 3 then begin
print,'Syntax - match, a, b, suba, subb, [ COUNT =, EPSILON=, /SORT]'
print,' a,b -- input vectors for which to match elements'
print,' suba,subb -- output subscript vectors of matched elements'
return
endif
da = size(a,/type) & db =size(b,/type)
if keyword_set(sort) then hist = 0b else $
hist = (( da LE 3 ) or (da GE 12)) and ((db LE 3) or (db GE 12 ))
if not hist then begin ;Non-integer calculation
na = N_elements(a) ;number of elements in a
nb = N_elements(b) ;number of elements in b
; Check for a single element array
if (na EQ 1) or (nb EQ 1) then begin
if (nb GT 1) then begin
subb = where(b EQ a[0], nw)
if (nw GT 0) then suba = replicate(0,nw) else suba = [-1]
endif else begin
suba = where(a EQ b[0], nw)
if (nw GT 0) then subb = replicate(0,nw) else subb = [-1]
endelse
count = nw
return
endif
c = [ a, b ] ;combined list of a and b
ind = [ lindgen(na), lindgen(nb) ] ;combined list of indices
vec = [ bytarr(na), replicate(1b,nb) ] ;flag of which vector in combined
;list 0 - a 1 - b
; sort combined list
sub = sort(c)
c = c[sub]
ind = ind[sub]
vec = vec[sub]
; find duplicates in sorted combined list
n = na + nb ;total elements in c
if epsilon eq 0. then $
firstdup = where( (c EQ shift(c,-1)) and (vec NE shift(vec,-1)), Count ) $
else $
firstdup = where( (abs(c - shift(c,-1)) lt epsilon) and (vec NE shift(vec,-1)), Count )
if Count EQ 0 then begin ;any found?
suba = lonarr(1)-1
subb = lonarr(1)-1
return
end
dup = lonarr( Count*2 ) ;both duplicate values
even = lindgen( N_elements(firstdup))*2 ;Changed to LINDGEN 6-Sep-1991
dup[even] = firstdup
dup[even+1] = firstdup+1
ind = ind[dup] ;indices of duplicates
vec = vec[dup] ;vector id of duplicates
subb = ind[ where( vec, complement = vzero) ] ;b subscripts
suba = ind[ vzero]
endif else begin ;Integer calculation using histogram.
minab = min(a, MAX=maxa) > min(b, MAX=maxb) ;Only need intersection of ranges
maxab = maxa < maxb
;If either set is empty, or their ranges don't intersect:
; result = NULL (which is denoted by integer = -1)
!ERR = -1
suba = -1
subb = -1
COUNT = 0L
if (maxab lt minab) or (maxab lt 0) then return
ha = histogram([a], MIN=minab, MAX=maxab, reverse_indices=reva)
hb = histogram([b], MIN=minab, MAX=maxab, reverse_indices=revb)
r = where((ha ne 0) and (hb ne 0), count)
if count gt 0 then begin
suba = reva[reva[r]]
subb = revb[revb[r]]
endif
endelse
return
end
;+
; NAME:
; MRD_SKIP
; PURPOSE:
; Skip a number of bytes from the current location in a file or a pipe
; EXPLANATION:
; First tries using POINT_LUN and if this doesn't work, perhaps because
; the unit is a pipe or a socket, MRD_SKIP will just read in the
; requisite number of bytes.
; CALLING SEQUENCE:
; MRD_SKIP, Unit, Nskip
;
; INPUTS:
; Unit - File unit for the file or pipe in question, integer scalar
; Nskip - Number of bytes to be skipped, positive integer
; NOTES:
; This routine should be used in place of POINT_LUN wherever a pipe
; or socket may be the input unit (see the procedure FXPOSIT for an
; example). Note that it assumes that it can only work with nskip >= 0
; so it doesn't even try for negative values.
;
; For reading a pipe, MRD_SKIP currently uses a maximum buffer size
; of 8 MB. This chunk value can be increased for improved efficiency
; (or decreased if you really have little memory.)
; REVISION HISTORY:
; Written, Thomas A. McGlynn July 1995
; Don't even try to skip bytes on a pipe with POINT_LUN, since this
; might reset the current pointer W. Landsman April 1996
; Increase buffer size, check fstat.compress W. Landsman Jan 2001
; Only a warning if trying read past EOF W. Landsman Sep 2001
; Use 64bit longword for skipping in very large files W. Landsman Sep 2003
; Assume since V5.4, fstat.compress available W. Landsman April 2006
; POINT_LUN for compressed files is as fast as any W. Landsman Oct 2006
; Don't try to use POINT_LUN on compressed files W. Landsman Dec. 2006
;:Private:
;-
pro eve_rwf_mrd_skip, unit, nskip
On_error,2
if nskip le 0 then return
compress = (fstat(unit)).compress
; We try to use POINT_LUN but if an error ocurrs, we just read in the bytes
if not compress then begin
On_IOerror, byte_read
point_lun, -unit, curr_pos
On_IOerror, null
if curr_pos NE -1 then point_lun, unit, long64(curr_pos) + nskip
return
endif
; Otherwise, we have to explictly read the number of bytes to skip
; If the number is very large we don't want to create a array so skip
; in chunks of 8 Megabyte
byte_read:
chunk = 8000000L
buf = bytarr(nskip<chunk, /nozero)
nleft = nskip
on_ioerror, DONE
while (nleft gt 0) do begin
readu, unit, buf
nleft = nleft - chunk
if (nleft gt 0 and nleft lt chunk) then buf = buf[0:nleft-1]
endwhile
return
DONE: message,'Warning - Byte padding in FITS file may not be correct',/CON
return
end
;+
; NAME:
; REMCHAR
; PURPOSE:
; Remove all appearances of character (char) from string (st)
;
; CALLING SEQUENCE:
; REMCHAR, ST, CHAR
;
; INPUT-OUTPUT:
; ST - String from which character will be removed, scalar or vector
; INPUT:
; CHAR- Single character to be removed from string or all elements of a
; string array
;
; EXAMPLE:
; If a = 'a,b,c,d,e,f,g' then
;
; IDL> remchar,a, ','
;
; will give a = 'abcdefg'
;
; REVISIONS HISTORY
; Written D. Lindler October 1986
; Test if empty string needs to be returned W. Landsman Feb 1991
; Work on string arrays W. Landsman August 1997
; Avoid 32 bit integer overflow K. Tolbert/W. Landsman Feb 2007
;:Private:
;-
pro eve_rwf_remchar,st,char ;Remove character
compile_opt idl2
if N_params() LT 2 then begin
print,'Syntax - REMCHAR, string, character'
return
endif
bchar = byte(char) & bchar = bchar[0] ;Convert character to byte
for i = 0L,N_elements(st)-1 do begin
bst = byte(st[i])
good = where( bst NE bchar, Ngood)
if Ngood GT 0 then st[i] = string(bst[good]) else st[i] = ''
endfor
return
end
;+
; NAME:
; STRN
; PURPOSE:
; Convert a number to a string and remove padded blanks.
; EXPLANATION:
; The main and original purpose of this procedure is to convert a number
; to an unpadded string (i.e. with no blanks around it.) However, it
; has been expanded to be a multi-purpose formatting tool. You may
; specify a length for the output string; the returned string is either
; set to that length or padded to be that length. You may specify
; characters to be used in padding and which side to be padded. Finally,
; you may also specify a format for the number. NOTE that the input
; "number" need not be a number; it may be a string, or anything. It is
; converted to string.
;
; CALLING SEQEUNCE:
; tmp = STRN( number, [ LENGTH=, PADTYPE=, PADCHAR=, FORMAT = ] )
;
; INPUT:
; NUMBER This is the input variable to be operated on. Traditionally,
; it was a number, but it may be any scalar type.
;
; OPTIONAL INPUT:
; LENGTH This KEYWORD specifies the length of the returned string.
; If the output would have been longer, it is truncated. If
; the output would have been shorter, it is padded to the right
; length.
; PADTYPE This KEYWORD specifies the type of padding to be used, if any.
; 0=Padded at End, 1=Padded at front, 2=Centered (pad front/end)
; IF not specified, PADTYPE=1
; PADCHAR This KEYWORD specifies the character to be used when padding.
; The default is a space (' ').
; FORMAT This keyword allows the FORTRAN type formatting of the input
; number (e.g. '(f6.2)')
;
; OUTPUT:
; tmp The formatted string
;
; USEFUL EXAMPLES:
; print,'Used ',strn(stars),' stars.' ==> 'Used 22 stars.'
; print,'Attempted ',strn(ret,leng=6,padt=1,padch='0'),' retries.'
; ==> 'Attempted 000043 retries.'
; print,strn('M81 Star List',length=80,padtype=2)
; ==> an 80 character line with 'M81 Star List' centered.
; print,'Error: ',strn(err,format='(f15.2)')
; ==> 'Error: 3.24' or ==> 'Error: 323535.22'
;
; HISTORY:
; 03-JUL-90 Version 1 written by Eric W. Deutsch
; 10-JUL-90 Trimming and padding options added (E. Deutsch)
; 29-JUL-91 Changed to keywords and header spiffed up (E. Deutsch)
; Ma7 92 Work correctly for byte values (W. Landsman)
; 19-NOV-92 Added Patch to work around IDL 2.4.0 bug which caused an
; error when STRN('(123)') was encountered. (E. Deutsch)
; Converted to IDL V5.0 W. Landsman September 1997
;:Private:
;-
function eve_rwf_strn, number, LENGTH = length, PADTYPE = padtype, PADCHAR = padchar, $
FORMAT = Format
On_error,2
if ( N_params() LT 1 ) then begin
print,'Call: IDL> tmp=STRN(number,[length=,padtype=,padchar=,format=])'
print,"e.g.: IDL> print,'Executed ',strn(ret,leng=6,padt=1,padch='0'),' retries.'"
return,''
endif
if (N_elements(padtype) eq 0) then padtype=1
if (N_elements(padchar) eq 0) then padchar=' '
if (N_elements(Format) eq 0) then Format=''
padc = byte(padchar)
pad = string(replicate(padc[0],200))
ss=size(number) & PRN=1 & if (ss[1] eq 7) then PRN=0
if ( Format EQ '') then tmp = strtrim( string(number, PRINT=PRN),2) $
else tmp = strtrim( string( number, FORMAT=Format, PRINT=PRN),2)
if (N_elements(length) eq 0) then length=strlen(tmp)
if (strlen(tmp) gt length) then tmp=strmid(tmp,0,length)
if (strlen(tmp) lt length) and (padtype eq 0) then begin
tmp = tmp+strmid(pad,0,length-strlen(tmp))
endif
if (strlen(tmp) lt length) and (padtype eq 1) then begin
tmp = strmid(pad,0,length-strlen(tmp))+tmp
endif
if (strlen(tmp) lt length) and (padtype eq 2) then begin
padln=length-strlen(tmp) & padfr=padln/2 & padend=padln-padfr
tmp=strmid(pad,0,padfr)+tmp+strmid(pad,0,padend)
endif
return,tmp
end
;+
; NAME:
; TEXTCLOSE
;
; PURPOSE:
; Close a text outpu file previously opened with TEXTOPEN
; EXPLANATION:
; procedure to close file for text output as specifed
; by the (non-standard) system variable !TEXTOUT.
;
; CALLING SEQUENCE:
; textclose, [ TEXTOUT = ]
;
; KEYWORDS:
; textout - Indicates output device that was used by
; TEXTOPEN
;
; SIDE EFFECTS:
; if !textout is not equal to 5 and the textunit is
; opened. Then unit !textunit is closed and released
;
; HISTORY:
; D. Lindler Dec. 1986 (Replaces PRTOPEN)
; Test if TEXTOUT is a scalar string W. Landsman August 1993
; Can't close unit -1 (Standard Output) I. Freedman April 1994
; Converted to IDL V5.0 W. Landsman September 1997
;:Private:
;-
pro eve_rwf_textclose,textout=textout
;-----------------------------------------------------------
; CLOSE PROPER UNIT
;
if N_elements( textout ) EQ 0 then textout = !textout ;use default
ptype = size( textout ) ;Test if TEXTOUT is a scalar string
if ptype[1] EQ 7 then text_out = 6 else text_out = textout
if ( text_out NE 5 ) then begin
if !textunit ne 0 AND !textunit ne -1 then begin
free_lun, !TEXTUNIT
!textunit = 0
end
end
return
end
;+
; NAME:
; TEXTOPEN
; PURPOSE:
; Open a device specified by TEXTOUT with unit !TEXTUNIT
; EXPLANATION:
; Procedure to open file for text output. The type of output
; device (disk file or terminal screen) is specified by the
; TEXTOUT keyword or the (nonstandard) system variable !TEXTOUT.
;
; CALLING SEQUENCE:
; textopen, program, [ TEXTOUT =, /STDOUT, /SILENT, MORE_SET=, WIDTH= ]
;
; INPUTS:
; program - scalar string giving name of program calling textopen
;
; OPTIONAL INPUT KEYWORDS:
; TEXTOUT - Integer scalar (0-7) specifying output file/device to be
; opened (see below) or scalar string giving name of output file.
; If TEXTOUT is not supplied, then the (non-standard) system
; variable !TEXTOUT is used.
; /SILENT - By default, TEXTOPEN prints an informational message when
; opening a file for hardcopy output. Set /SILENT (or !QUIET)
; to suppress this message.
; /STDOUT - if this keyword is set and non-zero, then the standard output
; (unit = -1) is used for TEXTOUT=1 or TEXTOUT=2. The use
; of STDOUT has 2 possible advantages:
; (1) the output will appear in a journal file
; (2) Many Unix machines print spurious control characters when
; printing to /dev/tty. These characters are eliminated by
; setting /STDOUT
;
; The disadvantage of /STDOUT is that the /MORE option is not
; available.
;
; WIDTH - Specify line width for hardcopy output line wrapping (passed onto OPENW).
;
; OPTIONAL OUTPUT KEYWORD:
; MORE_SET - Returns 1 if the output unit was opened with /MORE. This
; occurs if (1) TEXTOUT = 1 and (2) the device is a tty, and
; (3) /STDOUT is not set. User can use the returned value
; of MORE_SET to determine whether to end output when user
; presses 'Q'.
; SIDE EFFECTS:
; The following dev/file is opened for output. Different effects
; occur depending whether the standard output is a GUI (Macintosh,
; Windows, Unix/IDLTool) or a TTY
;
; textout=0 Nowhere
; textout=1 if a TTY then TERMINAL using /more option
; otherwise standard (Unit=-1) output
; textout=2 if a TTY then TERMINAL without /more option
; otherwise standard (Unit=-1) output
; textout=3 <program>.prt
; textout=4 laser.tmp
; textout=5 user must open file
; textout=7 same as 3 but text is appended to <program>.prt
; file if it already exists.
; textout = filename (default extension of .prt)
;
; The unit to be opened is obtained with the procedure GET_LUN
; unless !TEXTOUT=5. The unit number is placed in system variable
; !TEXTUNIT. For !TEXTOUT=5 the user must set !TEXTUNIT to the
; appropriate unit number.
;
; NOTES:
; When printing to a TTY terminal, the output will *not* appear in an
; IDL JOURNAL session, unlike text printed with the PRINT command.
;
; NON-STANDARD SYSTEM VARIABLES:
; TEXTOPEN will automatically define the following system variables if
; they are not previously defined:
;
; DEFSYSV,'!TEXTOUT',1
; DEFSYSV,'!TEXTUNIT',0
; HISTORY:
; D. Lindler Dec. 1986
; Keyword textout added, J. Isensee, July, 1990
; Made transportable, D. Neill, April, 1991
; Trim input PROGRAM string W. Landsman Feb 1993
; Don't modify TEXTOUT value W. Landsman Aug 1993
; Modified for MacOS I. Freedman April 1994
; Modified for output terminals without a TTY W. Landsman August 1995
; Added /STDOUT keyword W. Landsman April 1996
; added textout=7 option, D. Lindler, July, 1996
; Exit with RETURN instead of RETALL W. Landsman June 1999
; In IDL V5.4 filepath(/TERMINAL) not allowed in the IDLDE WL August 2001
; Added MORE_SET output keyword W.Landsman January 2002
; Added /SILENT keyword W. Landsman June 2002
; Define !TEXTOUT and !TEXTUNIT if needed. R. Sterner, 2002 Aug 27
; Return Calling Sequence if no parameters supplied W.Landsman Nov 2002
; Remove VMS specific code W. Landsman Sep 2006
; Make sure MORE_SET is always defined W. Landsman Jan 2007
; Added WIDTH keyword J. Bailin Nov 2010
; Use V6.0 notation W. Landsman April 2011
;:Private:
;-
PRO eve_rwf_TEXTOPEN,PROGRAM,TEXTOUT=TEXTOUT, STDOUT = STDOUT, MORE_SET = more_set, $
SILENT = silent, WIDTH = width
;-----------------------------------------------------------
On_Error,2
compile_opt idl2
if N_params() LT 1 then begin
print,'Syntax - TEXTOPEN, program, [ TEXTOUT =, /STDOUT, /SILENT,'
print,' MORE_SET=, WIDTH= ]'
return
endif
defsysv,'!TEXTOUT',exists=ex ; Check if !TEXTOUT exists.
if ex eq 0 then defsysv,'!TEXTOUT',1 ; If not define it.
defsysv,'!TEXTUNIT',exists=ex ; Check if !TEXTUNIT exists.
if ex eq 0 then defsysv,'!TEXTUNIT',0 ; If not define it.
more_set = 0
;
; Open proper unit.
;
if N_elements( textout ) NE 1 then textout = !textout ;use default output dev.
; keywords for openw
if n_elements(width) gt 0 then openw_keywords = {width: width}
if size(textout,/tname) EQ 'STRING' then begin ;test if filename entered
filename = textout
j = strpos(filename,'.') ;test if file extension given
if j lt 0 then filename = filename + ".prt"
text_out = 6
endif else text_out = textout
if TEXT_OUT eq 5 then begin
if !TEXTUNIT eq 0 then begin
print,' '
print,' You must set !TEXTUNIT to the desired unit number...'
print,' ...see following example'
print,' '
print,' OPENW, LUN, filename, /GET_LUN
print,' !TEXTUNIT = LUN
print,' DBPRINT...
print,'
print,' Action: returning'
print,' '
return
end
return
end
stndout = fstat(-1)
isatty = (stndout.isatty) && (~stndout.isagui) && $
(~keyword_set(STDOUT))
if isatty || (text_out GT 2) then begin
if !TEXTUNIT GT 0 then free_lun,!TEXTUNIT
get_lun,unit
!TEXTUNIT = unit
endif else !TEXTUNIT = -1 ;standard output
more_set = (text_out EQ 1) && isatty
case text_out of
1: if isatty then openw, !TEXTUNIT, filepath(/TERMINAL), /MORE, _extra=openw_keywords
2: if isatty then openw, !TEXTUNIT, filepath(/TERMINAL) , _extra=openw_keywords
3: begin
oname = strlowcase( strtrim( PROGRAM,2) +'.prt')
openw, !TEXTUNIT, oname, _extra=openw_keywords
if ~keyword_set(SILENT) then $
message,'Output is being directed to a file ' + oname,/INFORM
end
4: openw, !TEXTUNIT, 'laser.tmp', _extra=openw_keywords
6: begin
openw,!TEXTUNIT,filename, _extra=openw_keywords
if ~keyword_set(SILENT) then $
message,'Output is being directed to a file ' + filename,/INFORM
end
7: begin
oname = strlowcase(strtrim( PROGRAM,2) +'.prt')
openw, !TEXTUNIT, oname, /append, _extra=openw_keywords
if ~keyword_set(SILENT) then $
message,'Output is being appended to file ' + oname,/INFORM
for i=0,3 do printf,!textunit,' ' ;added a couple of blank lines
end
0: openw,!TEXTUNIT, strtrim(PROGRAM,2) + '.tmp',/DELETE, _extra=openw_keywords
else: begin
!textunit = 0
print,' '
print,' Invalid value for TEXTOUT =',TEXTOUT
print,' '
print,' ...the possibilities are:
print,' '
print,' textout=0 nowhere
if isatty then begin
print,' textout=1 terminal with /more
print,' textout=2 terminal without /more
endif else begin
print,' textout=1 terminal
print,' textout=2 terminal
endelse
print,' textout=3 file <program>.prt
print,' textout=4 file laser.tmp
print,' textout=5 User supplied file
print,' textout = filename (default extension of .prt)
print,' textout=7 Same as 3 but append the file
print,' '
print,' Action: returning
print,' '
return
end
endcase
return
end ; textout
;+
; NAME:
; VALID_NUM()
; PURPOSE:
; Check if a string is a valid number representation.
; EXPLANATION:
; The input string is parsed for characters that may possibly
; form a valid number. It is more robust than simply checking
; for an IDL conversion error because that allows strings such
; as '22.3qwert' to be returned as the valid number 22.3
;
; This function had a major rewrite in August 2008 to use STREGEX
; and allow vector input. It should be backwards compatible.
; CALLING SEQUENCE:
; IDL> status = valid_num(string [,value] [,/integer])
;
; INPUTS:
; string - the string to be tested, scalar or array
;
; RETURNS
; status - byte scalar or array, same size as the input string
; set to 1 where the string is a valid number, 0 for invalid
; OPTIONAL OUTPUT:
; value - The value the string decodes to, same size as input string.
; This will be returned as a double precision number unless
; /INTEGER is present, in which case a long integer is returned.
;
; OPTIONAL INPUT KEYWORD:
; /INTEGER - if present code checks specifically for an integer.
; EXAMPLES:
; (1) IDL> print,valid_num(3.2,/integer)
; --> 0 ;Since 3.2 is not an integer
; (2) IDL> str =['-0.03','2.3g', '3.2e12']
; IDL> test = valid_num(str,val)
; test = [1,0,1] & val = [-0.030000000 ,NaN ,3.2000000e+12]
; REVISION HISTORY:
; Version 1, C D Pike, RAL, 24-May-93
; Version 2, William Thompson, GSFC, 14 October 1994
; Added optional output parameter VALUE to allow
; VALID_NUM to replace STRNUMBER in FITS routines.
; Version 3 Wayne Landsman rewrite to use STREGEX, vectorize
; Version 4 W.L. (fix from C. Markwardt) Better Stregex expression,
; was missing numbers like '134.' before Jan 1 2010
;:Private:
;-
FUNCTION eve_rwf_valid_num, string, value, INTEGER=integer
On_error,2
compile_opt idl2
; A derivation of the regular expressions below can be found on
; http://wiki.tcl.tk/989
if keyword_set(INTEGER) then $
st = '^[-+]?[0-9][0-9]*$' else $ ;Integer
st = '^[-+]?([0-9]+\.?[0-9]*|\.[0-9]+)([eEdD][-+]?[0-9]+)?$' ;F.P.
;Simple return if we just need a boolean test.
if N_params() EQ 1 then return, stregex(strtrim(string,2),st,/boolean)
vv = stregex(strtrim(string,2),st,/boolean)
if size(string,/N_dimen) EQ 0 then begin ;Scalar
if vv then $
value= keyword_set(integer) ? long(string) : double(string)
endif else begin ;Array
g = where(vv,Ng)
if Ng GT 0 then begin ;Need to create output vector
if keyword_set(integer) then begin
value = vv*0L
value[g] = long(string[g])
endif else begin
value = replicate(!VALUES.D_NAN,N_elements(vv))
value[g] = double(string[g])
endelse
endif
endelse
return,vv
end
;+
; NAME:
; MRD_STRUCT
; PURPOSE:
; Return a structure as defined in the names and values data.
; CALLING SEQUENCE:
; struct = MRD_STRUCT(NAMES, VALUES, NROW, STRUCTYP='name' )
; INPUT PARAMETERS:
; NAMES = A string array of names of structure fields.
; VALUES = A string array giving the values of the structure
; fields. See examples below.
; NROW = The number of elements in the structure array.
;
; RETURNS:
; A structure as described in the parameters or 0 if an error
; is detected.
;
; OPTIONAL KEYWORD PARAMETERS:
; /NO_EXECUTE - If set then the use of the EXECUTE() statement is avoided.
; By default, the NO_EXECUTE pathway is used if IDL is
; running under the Virtual Machine. Note if /NO_EXECUTE
; is set, then the user cannot supply arbitary values, but
; all possible values used by MRDFITS will be allowed.
; STRUCTYP = The structure type. Since IDL does not allow the
; redefinition of a named structure it is an error
; to call MRD_STRUCT with different parameters but
; the same STRUCTYP in the same session. If this
; keyword is not set an anonymous structure is created.
; COMMON BLOCKS:
; MRD_COMMON
; SIDE EFFECTS:
; May create a temporary file if the structure definition is too long
; for the EXECUTE function and using old style structures
;
; RESTRICTIONS:
; By default, the program defines the structure in a long string
; which is executed with CREATE_STRUCT within a single EXECUTE statement.
;
; If program is being run in the IDL Virtual machine (EXECUTE statement
; not allowed), then a separate CREATE_STRUCT statement is called
; for each tag. This mode does not have the full capabilities of the
; normal mode, but should be sufficient for use with MRDFITS().
; PROCEDURE:
; A structure definition is created using the parameter values.
; MRD_NSTRUCT is called and generates the structure in pieces using the
; execute and create_struct keywords.
;
; EXAMPLES:
; (1) str = mrd_struct(['fld1', 'fld2'], ['0','dblarr(10,10)'],3)
; print, str(0).fld2(3,3)
; Note that "0" is always considered short integer even if the default
; integer is set to long.
;
;
; (2) str = mrd_struct(['a','b','c','d'],['1', '1.', '1.d0', "'1'"],1)
; ; returns a structure with integer, float, double and string
; ; fields.
; PROCEDURE CALLS:
; GETTOK() - needed for virtual machine mode only
; MODIFICATION HISTORY:
; Created by T. McGlynn October, 1994.
; Modified by T. McGlynn September, 1995.
; Added capability to create substructures so that structure
; may contain up to 4096 distinct elements. [This can be
; increased by futher iteration of the process used if needed.]
; Removed V4.0 reference to common block October 1997
; Allowed unlimited number of structure elements if the version
; is greater than 5.0. Put back in code to handle prior versions.
; The [] will need to be translated back to () for this to
; work. T. McGlynn December 15 1998.
; Add MRD_NSTRUCT since IDL has mysterious problems compiling
; very large structures.
; Removed TEMPDIR and OLD_STRUCT keywords W. Landsman October 2003
; Alternate pathway without EXECUTE for V6.0 virtual machine, D. Lindler
; Removed limit on EXECUTE statement. W. Landsman October 2003
; Restore EXECUTE limit (sigh...), added NO_EXECUTE keyword
; W. Landsman July 2004
; Fix use of STRUCTYP with /NO_EXECUTE W. Landsman June 2005
; Assume since V6.0 (lmgr function available), remove 131 string length
; limit for execute W. Landsman Jun 2009
; Restore EXECUTE limit (sigh...) W. Landsman July 2009
; Make sure "0" is a short integer even with compile_opt idl2 July 2010
;:Private:
;-
function eve_rwf_mrd_struct, names, values, nrow, no_execute = no_execute, $
structyp=structyp, tempdir=tempdir, silent=silent, old_struct=old_struct
; Check that the number of names is the same as the number of values.
compile_opt idl2
; Keywords TEMPDIR, SILENT and OLD_STRUCT no longer do anything but are kept
; for backward compatibility.
noexecute = keyword_set(no_execute) or lmgr(/vm)
if noexecute then begin
ntags = n_elements(names)
for i=0,ntags-1 do begin
;
; create variable with the specified data type
;
case strlowcase(values[i]) of
;
; scalar values
;
'0b': v = 0B
'0' : v = 0S
'0l': v = 0L
'0ll' : v = 0LL
'0.': v = 0.0
'0.0d0': v = 0.0d0
'0.d0': v = 0.0d0
'" "': v = " " ;Added July 2004
'complex(0.,0.)': v = complex(0.,0.)
'dcomplex(0.d0,0.d0)': v = dcomplex(0.d0,0.d0)
;
; strings and arrays
;`
else: begin
value = values[i]
eve_rwf_remchar,value,"'"
eve_rwf_remchar,value,'"'
if strlen(value) EQ 1 then v= value else begin
type = eve_rwf_gettok(value,'(')
if type eq 'string' then $
junk = eve_rwf_gettok(value,',') ;remove "replicate(32b"
dimen_string = eve_rwf_gettok(value,')')
dimen = long(strsplit(dimen_string,',',/extract))
case type of
'bytarr': v = make_array(dimen=dimen,/byte)
'intarr': v = make_array(dimen=dimen,/int)
'fltarr': v = make_array(dimen=dimen,/float)
'lonarr': v = make_array(dimen=dimen,/long)
'lon64arr': v = make_array(dimen=dimen,/long64)
'dblarr': v = make_array(dimen=dimen,/double)
'complexarr': v = make_array(dimen=dimen,/complex)
'dcomplexarr': v = make_array(dimen=dimen,/dcomplex)
'ptr_new': v = ptr_new()
'string': begin
ndimen = n_elements(dimen)-1
if ndimen gt 0 then begin
v = make_array(dimen=dimen[1:*],/string)
v[*] = string(replicate(32B,dimen[0]))
end else v = string(replicate(32B,dimen[0]))
end
else: message,'ERROR - Invalid field value: ' + values[i]
endcase
endelse
end
endcase
if i eq 0 then struct = create_struct(names[i],v) $
else struct = create_struct(temporary(struct),names[i],v)
end; for i
endif else begin
; Build up the structure use a combination of execute and
; create_struct calls. Basically we build as many rows as
; will fit in an execute call and create that structure. Then
; we append that structure to whatever we've done before using
; create_struct
nel = N_elements(names)
strng = "a={"
comma = ' '
for i=0,nel-1 do begin
fval = values[i]
if (fval eq '0') then fval = '0s'
; Now for each element put in a name/value pair.
tstrng = strng + comma+names[i] + ':' + fval
; The nominal max length of the execute is 131
; We need one chacacter for the "}"
if strlen(tstrng) gt 130 then begin
strng = strng + "}"
res = execute(strng)
if res eq 0 then return, 0
struct = n_elements(struct) eq 0 ? a: $
create_struct(temporary(struct), a)
strng = "a={" + names[i] + ":" + fval
endif else strng = tstrng
comma = ","
endfor
if strlen(strng) gt 3 then begin
strng = strng + "}"
res = execute(strng)
if res eq 0 then return, 0
struct = n_elements(struct) eq 0 ? a : create_struct(temporary(struct), a)
endif
endelse
if keyword_set(structyp) then $
struct = create_struct(temporary(struct), name=structyp)
if nrow le 1 then return, struct $
else return, replicate(struct, nrow)
end
;+
; Read all of the HDUs in a FITS file, creating a merged set of
; structures for the data, and string arrays for the keywords.
;
;:Categories:
; User
;
;:Params:
; infname_: in, required
; A scalar string for a FITS file. If comressed with gzip (.gz) MRDFITS is used in compress mode
;:Keywords:
; _extra : in, optional
; additional parameters to pass to mrdfits (refer to mrdfits.pro)
; verbose : in, optional
; report information on each HDU read to stdout (nothing is reported normally)
; swap: in, optional
; Set this flag to force an endian swap. Otherwise the program tries to detect if one is necesssary
; automatically, by looking for a timestamp and deciding if it is in a reasonable range, with a swap if not.
; You can specify swap=0 to force the program to not autodetect and not swap.
;
;:Returns:
; a structure that contains structures from
; each HDU and an associated string array for the keywords
;
; SIDE EFFECTS:
; Substructure names correspond to the keyword "EXTNAME", if absent,
; then a default naming convention is used.
;
; RESTRICTIONS:
; Requires fits_info.pro and mrdfits.pro (with it's own dependencies).
;
; This should be compatible with all OSes, but we only test on Linux
; and Mac OS X. However, if you encounter problems, try decompressing
; the FITS files before you call this function.
;
;:Examples:
; ::
; IDL> data=eve_read_whole_fits('EVS_L2_2010120_00_002_01.fit.gz',/verbose)
;
;-
function eve_read_whole_fits,infname_,verbose=verbose,swap=swap,_extra=extra
; MODIFICATION HISTORY:
; 2/21/10 DLW Modified from CJs pre-release version.
; 8/3/2011 CDJ Use MRDFITS built-in compression handling, so it works in Windows also.
; Renamed to SSW standards
; 9/1/2011 CDJ added /swap_if_little to openr, to handle endian issues we've been having.
;
; $Id: eve_read_whole_fits.pro,v 3.3 2011/09/02 21:49:50 dlwoodra Exp $
compress=strlowcase((reverse(strsplit(infname_,'.',/extract)))[0]) eq 'gz'
infn = infname_
; determine the number of HDUs to read
eve_rwf_fits_info,silent=~keyword_set(verbose),infn,n_ext=n_hdus ; the only programmatic way to get number of HDUs?
openr,inf,infn,/get_lun,compress=compress,/swap_if_little
status=0
hdu=0
this_hdu=eve_rwf_mrdfits(inf,0,this_header,/unsigned,silent=~keyword_set(verbose),compress=compress,_extra=extra,status=status)
while status ge 0 and hdu le n_hdus do begin
if hdu eq 0 then begin
result=create_struct('primary',this_hdu,'primary_head',this_header)
endif else begin
w=where(strmid(this_header,0,8) eq 'EXTNAME ',count)
if count eq 1 then begin
this_hdu_name=strtrim((strsplit(this_header[w],"'",/extract))[1])
endif else begin
this_hdu_name=string(format='(%"HDR%03d")',hdu)
endelse
this_hdr_name=this_hdu_name+"_HEADER"
result=create_struct(result,this_hdu_name,this_hdu,this_hdr_name,this_header)
endelse
hdu++
;0 means skip zero hdus
if hdu le n_hdus then this_hdu=eve_rwf_MRDfits(inf,0,this_header,/unsigned,silent=~keyword_set(verbose),_extra=extra,status=status)
endwhile
free_lun,inf
if N_elements(swap) eq 0 then begin
t=tag_names(result)
w=where(strupcase(t) eq "SPECTRUM" or strupcase(t) eq "LINESDATA" or strupcase(t) eq "DATA", count)
if count gt 0 then begin
t=result.(w[0])
tagnames = tag_names(t) ; string of tag names
tmp = where(tagnames eq 'TAI',do_tai)
if do_tai gt 0 then $
if t[0].tai lt 1.4832d9 or t[0].tai gt 2.2406d9 then swap=1
tmp = where(tagnames eq 'YYYYDOY',do_yyyydoy)
if do_yyyydoy gt 0 then $
if t[0].yyyydoy lt 2005001L or t[0].yyyydoy gt 2029001L then swap=1
end
end
if keyword_set(swap) then result=swap_endian(temporary(result))
return,result
end