OV-GSO-DC / dustem-wrapper_idl

Commit b4731d231163aa8976e9b0adc8e4fa9de2d9a7f8

Authored by Annie Hughes
1 parent 67099c3f
Exists in master

removed redundant IDL from idl_misc

Showing 3 changed files with 0 additions and 3020 deletions   Show diff stats
Inline Side-by-side
src/idl_misc/matchdelim.pro deleted
View file @67099c3
... ... @@ -1,138 +0,0 @@
1   -;
2   -;+
3   -; NAME:
4   -; MATCHDELIM
5   -; PURPOSE:
6   -; Match open/close delimiters in a string.
7   -; CATEGORY:
8   -; text/strings
9   -; CALLING SEQUENCE:
10   -; position = matchdelim( strn, [openpos])
11   -; INPUTS:
12   -; strn -- a string containing an open in
13   -; delimiter (e.g. '{') in which you
14   -; want to find the matching closing
15   -; delimiter (e.g. '}')
16   -; KEYWORD PARAMETERS:
17   -; OPEN_DELIM -- A single character containing the opening in
18   -; delimiter (e.g. '('). Default is '{'
19   -; CLOSE_DELIM -- A single character containing the closing in
20   -; delimiter (e.g. ')'). Default is '}'
21   -; OUTPUTS:
22   -; position -- returns the position in strn of the out
23   -; closing delimiter, -1 if no closing found.
24   -; openpos -- Set to a named variable to receive the out
25   -; position of the first opening delimiter.
26   -; Optional.
27   -; COMMON BLOCKS:
28   -; SIDE EFFECTS:
29   -; NOTES:
30   -; - Any pair of (nonidentical) characters can be used as
31   -; delimiters.
32   -; EXAMPLE:
33   -; matchdelim('{one{two}}three') returns 9, the character just
34   -; before 'three'.
35   -; MODIFICATION HISTORY:
36   -; $Id: matchdelim.pro,v 1.3 1996/06/14 20:00:27 mcraig Exp $
37   -; $Log: matchdelim.pro,v $
38   -; Revision 1.3 1996/06/14 20:00:27 mcraig
39   -; Updated Copyright info.
40   -;
41   -; Revision 1.2 1996/05/09 00:22:17 mcraig
42   -; Removed restriction that open delim must be first char. Added argument
43   -; to allow for return of position of open delim.
44   -;
45   -; Revision 1.1 1996/01/31 18:41:06 mcraig
46   -; Initial revision
47   -;
48   -; RELEASE:
49   -; $Name: Rel_2_1 $
50   -;
51   -; COPYRIGHT:
52   -; Copyright (C) 1996 The Regents of the University of California, All
53   -; Rights Reserved. Written by Matthew W. Craig.
54   -; See the file COPYRIGHT for restrictions on distrubting this code.
55   -; This code comes with absolutely NO warranty; see DISCLAIMER for details.
56   -;-
57   -;
58   -FUNCTION Matchdelim, InString, OpenPos, $
59   - OPEN_DELIM=OpenDelim, $
60   - CLOSE_DELIM=CloseDelim, $
61   - HELP=Help
62   -
63   -; Return to caller if error.
64   - On_error, 2
65   -
66   - IF (n_params() LT 1) OR keyword_set(Help) THEN BEGIN
67   - offset = ' '
68   - print, offset+'Match open/close delimiters in a string.'
69   - print, offset+'position = matchdelim( strn, [openpos])'
70   - print, offset+'Inputs:'
71   - print, offset+offset+'strn -- a string containing an open in'
72   - print, offset+offset+" delimiter (e.g. '{') in which you "
73   - print, offset+offset+' want to find the matching closing '
74   - print, offset+offset+" delimiter (e.g. '}')"
75   - print, offset+'Keywords:'
76   - print, offset+offset+'OPEN_DELIM -- A single character containing the opening in'
77   - print, offset+offset+" delimiter (e.g. '('). Default is '{'"
78   - print, offset+offset+'CLOSE_DELIM -- A single character containing the closing in'
79   - print, offset+offset+" delimiter (e.g. ')'). Default is '}'"
80   - print, offset+'Outputs:'
81   - print, offset+offset+'position -- returns the position in strn of the out'
82   - print, offset+offset+' closing delimiter, -1 if no closing found.'
83   - print, offset+offset+'openpos -- Set to a named variable to receive the out'
84   - print, offset+offset+' position of the first opening delimiter.'
85   - print, offset+offset+' Optional.'
86   - print, offset+'Example:'
87   - print, offset+offset+"matchdelim('a{one{two}}three') returns 10, the character just"
88   - print, offset+offset+" before 'three'. "
89   - print, offset+offset+$
90   - "a=matchdelim('aaa[bbb(ccc)]ddd[eee]',f,OP='[',CL=']')"
91   - print, offset+offset+" returns a=12 (just before ddd), f=3 "+$
92   - "(just before bbb)."
93   - return, -1
94   - ENDIF
95   -
96   -; Set default delimiters.
97   - IF n_elements(OpenDelim) EQ 0 THEN OpenDelim = '{'
98   - IF n_elements(CloseDelim) EQ 0 THEN CloseDelim = '}'
99   -
100   -; Make sure InString has more than 1 character.
101   - length = strlen(InString)
102   - IF (length LE 1) THEN return,-1
103   -
104   -; Return if no open delimiter
105   - OpenPos = strpos( InString, OpenDelim )
106   - IF (OpenPos EQ -1) THEN BEGIN
107   - print, 'Error: No opening delimiter'
108   - return, -1
109   - ENDIF
110   -
111   -; Convert strings to array of integers to speed processing.
112   - OpenDelim = fix((byte(OpenDelim))(0))
113   - CloseDelim = fix((byte(CloseDelim))(0))
114   - TmpStr = fix(byte(strmid( InString, OpenPos, length)))
115   -; Leave the -1* in here. This forces conversion from BYTE to INTEGER,
116   -; necessary because there are no negative BYTEs.
117   - TmpStr = (TmpStr EQ OpenDelim) $
118   - -1*(TmpStr EQ CloseDelim)
119   - length = n_elements(TmpStr)
120   -
121   -; Initialize count of number of delimiters. We've found one, the
122   -; first opener.
123   - BraceCnt = 1
124   - i=0
125   - WHILE (BraceCnt GT 0) AND (i LT length-1) DO BEGIN
126   - i = i+1
127   - BraceCnt = BraceCnt + TmpStr(i)
128   - ENDWHILE
129   -
130   - i = i + OpenPos
131   - IF (BraceCnt GT 0) THEN i = -1
132   - return, i
133   -END
134   -
135   -
136   -
137   -
138   -
src/idl_misc/mrd_hread.pro deleted
View file @67099c3
... ... @@ -1,96 +0,0 @@
1   -pro mrd_hread, unit, header, status, SILENT = silent, FIRSTBLOCK = firstblock
2   -;+
3   -; NAME:
4   -; MRD_HREAD
5   -;
6   -; PURPOSE:
7   -; Reads a FITS header from an opened disk file or Unix pipe
8   -; EXPLANATION:
9   -; Like FXHREAD but also works with compressed Unix files
10   -;
11   -; CALLING SEQUENCE:
12   -; MRD_HREAD, UNIT, HEADER [, STATUS, /SILENT ]
13   -; INPUTS:
14   -; UNIT = Logical unit number of an open FITS file
15   -; OUTPUTS:
16   -; HEADER = String array containing the FITS header.
17   -; OPT. OUTPUTS:
18   -; STATUS = Condition code giving the status of the read. Normally, this
19   -; is zero, but is set to -1 if an error occurs, or if the
20   -; first byte of the header is zero (ASCII null).
21   -; OPTIONAL KEYWORD INPUT:
22   -; /SILENT - If set, then warning messages about any invalid characters in
23   -; the header are suppressed.
24   -; /FIRSTBLOCK - If set, then only the first block (36 lines or less) of
25   -; the FITS header are read into the output variable. If only
26   -; size information (e.g. BITPIX, NAXIS) is needed from the
27   -; header, then the use of this keyword can save time. The
28   -; file pointer is still positioned at the end of the header,
29   -; even if the /FIRSTBLOCK keyword is supplied.
30   -; RESTRICTIONS:
31   -; The file must already be positioned at the start of the header. It
32   -; must be a proper FITS file.
33   -; SIDE EFFECTS:
34   -; The file ends by being positioned at the end of the FITS header, unless
35   -; an error occurs.
36   -; REVISION HISTORY:
37   -; Written, Thomas McGlynn August 1995
38   -; Modified, Thomas McGlynn January 1996
39   -; Changed MRD_HREAD to handle Headers which have null characters
40   -; A warning message is printed out but the program continues.
41   -; Previously MRD_HREAD would fail if the null characters were
42   -; not in the last 2880 byte block of the header. Note that
43   -; such characters are illegal in the header but frequently
44   -; are produced by poor FITS writers.
45   -; Converted to IDL V5.0 W. Landsman September 1997
46   -; Added /SILENT keyword W. Landsman December 2000
47   -; Added /FIRSTBLOCK keyword W. Landsman February 2003
48   -;-
49   - block = string(replicate(32b, 80, 36))
50   -
51   - w = [-1]
52   - nblock = 0
53   -
54   - while w[0] eq -1 do begin
55   -
56   - ; Shouldn't get eof in middle of header.
57   - if eof(unit) then begin
58   - free_lun, unit
59   - status = -1
60   - return
61   - endif
62   -
63   - on_ioerror, error_return
64   - readu, unit, block
65   - on_ioerror, null
66   -
67   - ; Check that there aren't improper null characters
68   - ; in strings that are causing them to be truncated.
69   - ; Issue a warning but continue if problems are found.
70   - w = where(strlen(block) ne 80)
71   - if (w[0] ne -1) then begin
72   - if not keyword_set(SILENT) then message, /INF, $
73   - 'Warning-Invalid characters in header'
74   - block[w] = string(replicate(32b, 80))
75   - endif
76   - w = where(strmid(block, 0, 8) eq 'END ')
77   - if nblock EQ 0 then begin
78   - if w[0] eq -1 then header = block $
79   - else header = [block[0:w[0]]]
80   - nblock = nblock + 1
81   - endif else begin
82   - if not keyword_set(firstblock) then begin
83   - if w[0] eq -1 then header = [header, block] $
84   - else header = [header, block[0:w[0]]]
85   - endif
86   - endelse
87   -
88   - endwhile
89   -
90   - status = 0
91   - return
92   -error_return:
93   - status = -1
94   - return
95   -end
96   -
src/idl_misc/mrdfits.pro deleted
View file @67099c3
... ... @@ -1,2786 +0,0 @@
1   -;+
2   -; NAME:
3   -; MRDFITS
4   -;
5   -; PURPOSE:
6   -; Read all standard FITS data types into arrays or structures.
7   -;
8   -; EXPLANATION:
9   -; Further information on MRDFITS is available at
10   -; http://idlastro.gsfc.nasa.gov/mrdfits.html
11   -;
12   -; CALLING SEQUENCE:
13   -; Result = MRDFITS( Filename/FileUnit,[Exten_no/Exten_name, Header],
14   -; /FSCALE , /DSCALE , /UNSIGNED,
15   -; ALIAS=strarr[2,n], /USE_COLNUM,
16   -; /NO_TDIM, ROWS = [a,b,...], $
17   -; /POINTER_VAR, /FIXED_VAR, EXTNUM=
18   -; RANGE=[a,b], COLUMNS=[a,b,...]), ERROR_ACTION=x,
19   -; COMPRESS=comp_prog, STATUS=status, /VERSION )
20   -;
21   -; INPUTS:
22   -; Filename = String containing the name of the file to be read or
23   -; file number of an open unit. If a unit is specified
24   -; if will be left open positioned to read the next HDU.
25   -; If the file name ends in .gz (or .Z on Unix systems)
26   -; the file will be dynamically decompressed.
27   -; FiluUnit = An integer file unit which has already been
28   -; opened for input. Data will be read from this
29   -; unit and the unit will be left pointing immediately
30   -; after the HDU that is read. Thus to read a compressed
31   -; file with many HDU's a user might do something like:
32   -; lun=fxposit(filename, 3) ; Skip the first three HDU's
33   -; repeat begin
34   -; thisHDU = mrdfits(lun, 0, hdr, status=status)
35   -; ... process the HDU ...
36   -; endrep until status lt 0
37   -;
38   -; Exten_no= Extension number to be read, 0 for primary array.
39   -; Assumed 0 if not specified.
40   -; If a unit rather than a filename
41   -; is specified in the first argument, this is
42   -; the number of HDU's to skip from the current position.
43   -; Exten_name - Name of the extension to read (as stored in the EXTNAME
44   -; keyword). This is a slightly slower method then specifying
45   -; the extension number.
46   -; OUTPUTS:
47   -; Result = FITS data array or structure constructed from
48   -; the designated extension. The format of result depends
49   -; upon the type of FITS data read.
50   -; Non-group primary array or IMAGE extension:
51   -; A simple multidimensional array is returned with the
52   -; dimensions given in the NAXISn keywords.
53   -; Grouped image data with PCOUNT=0.
54   -; As above but with GCOUNT treated as NAXIS(n+1).
55   -; Grouped image data with PCOUNT>0.
56   -; The data is returned as an array of structures. Each
57   -; structure has two elements. The first is a one-dimensional
58   -; array of the group parameters, the second is a multidimensional
59   -; array as given by the NAXIS2-n keywords.
60   -; ASCII and BINARY tables.
61   -; The data is returned as a structure with one column for
62   -; each field in the table. The names of the columns are
63   -; normally taken from the TTYPE keywords (but see USE_COLNUM).
64   -; Bit field columns
65   -; are stored in byte arrays of the minimum necessary
66   -; length. Spaces and invalid characters are replaced by
67   -; underscores, and other invalid tag names are converted using
68   -; the IDL_VALIDNAME(/CONVERT_ALL) function.
69   -; Columns specified as variable length columns are stored
70   -; with a dimension equal to the largest actual dimension
71   -; used. Extra values in rows are filled with 0's or blanks.
72   -; If the size of the variable length column is not
73   -; a constant, then an additional column is created giving the
74   -; size used in the current row. This additional column will
75   -; have a tag name of the form L#_"colname" where # is the column
76   -; number and colname is the column name of the variable length
77   -; column. If the length of each element of a variable length
78   -; column is 0 then the column is deleted.
79   -;
80   -;
81   -; OPTIONAL OUTPUT:
82   -; Header = String array containing the header from the FITS extension.
83   -;
84   -; OPTIONAL INPUT KEYWORDS:
85   -; ALIAS The keyword allows the user to specify the column names
86   -; to be created when reading FITS data. The value of
87   -; this keyword should be a 2xn string array. The first
88   -; value of each pair of strings should be the desired
89   -; tag name for the IDL column. The second should be
90   -; the FITS TTYPE value. Note that there are restrictions
91   -; on valid tag names. The order of the ALIAS keyword
92   -; is compatible with MWRFITS.
93   -; COLUMNS - This keyword allows the user to specify that only a
94   -; subset of columns is to be returned. The columns
95   -; may be specified either as number 1,... n or by
96   -; name or some combination of these two.
97   -; If USE_COLNUM is specified names should be C1,...Cn.
98   -; The use of this keyword will not save time or internal
99   -; memory since the extraction of specified columns
100   -; is done after all columns have been retrieved from the
101   -; FITS file.
102   -; COMPRESS - This keyword allows the user to specify a
103   -; decompression program to use to decompress a file that
104   -; will not be automatically recognized based upon
105   -; the file name.
106   -; /DSCALE - As with FSCALE except that the resulting data is
107   -; stored in doubles.
108   -; ERROR_ACTION - Set the on_error action to this value (defaults
109   -; to 2).
110   -; /FIXED_VAR- Translate variable length columns into fixed length columns
111   -; and provide a length column for truly varying columns.
112   -; This was only behavior prior to V2.5 for MRDFITS and remains
113   -; the default (see /POINTER_VAR)
114   -; /FSCALE - If present and non-zero then scale data to float
115   -; numbers for arrays and columns which have either
116   -; non-zero offset or non-unity scale.
117   -; If scaling parameters are applied, then the corresponding
118   -; FITS scaling keywords will be modified.
119   -; NO_TDIM - Disable processing of TDIM keywords. If NO_TDIM
120   -; is specified MRDFITS will ignore TDIM keywords in
121   -; binary tables.
122   -; /POINTER_VAR- Use pointer arrays for variable length columns.
123   -; In addition to changing the format in which
124   -; variable length arrays are stored, if the pointer_var
125   -; keyword is set to any value other than 1 this also disables
126   -; the deletion of variable length columns. (See /FIXED_VAR)
127   -; Note that because pointers may be present in the output
128   -; structure, the user is responsible for memory management
129   -; when deleting or reassigning the structure (e.g. use HEAP_FREE
130   -; first).
131   -; RANGE - A scalar or two element vector giving the start
132   -; and end rows to be retrieved. For ASCII and BINARY
133   -; tables this specifies the row number. For GROUPed data
134   -; this will specify the groups. For array images, this
135   -; refers to the last non-unity index in the array. E.g.,
136   -; for a 3 D image with NAXIS* values = [100,100,1], the
137   -; range may be specified as 0:99, since the last axis
138   -; is suppressed. Note that the range uses IDL indexing
139   -; So that the first row is row 0.
140   -; If only a single value, x, is given in the range,
141   -; the range is assumed to be [0,x-1].
142   -; ROWS - A scalar or vector specifying a specific row or rows to read
143   -; (first row is 0). For example to read rows 0,
144   -; 12 and 23 only, set ROWS=[0,12,23]. Valid for images, ASCII
145   -; and binary tables, but not GROUPed data. For images
146   -; the row numbers refer to the last non-unity index in the array.
147   -; Cannot be used at the same time as the RANGE keyword
148   -; /SILENT - Suppress informative messages.
149   -; STRUCTYP - The structyp keyword specifies the name to be used
150   -; for the structure defined when reading ASCII or binary
151   -; tables. Generally users will not be able to conveniently
152   -; combine data from multiple files unless the STRUCTYP
153   -; parameter is specified. An error will occur if the
154   -; user specifies the same value for the STRUCTYP keyword
155   -; in calls to MRDFITS in the same IDL session for extensions
156   -; which have different structures.
157   -; /UNSIGNED - For integer data with appropriate zero points and scales
158   -; read the data into unsigned integer arrays.
159   -; /USE_COLNUM - When creating column names for binary and ASCII tables
160   -; MRDFITS attempts to use the appropriate TTYPE keyword
161   -; values. If USE_COLNUM is specified and non-zero then
162   -; column names will be generated as 'C1, C2, ... 'Cn'
163   -; for the number of columns in the table.
164   -; /VERSION Print the current version number
165   -;
166   -; OPTIONAL OUTPUT KEYWORDS:
167   -; EXTNUM - the number of the extension actually read. Useful if the
168   -; user specified the extension by name.
169   -; STATUS - A integer status indicating success or failure of
170   -; the request. A status of >=0 indicates a successful read.
171   -; Currently
172   -; 0 -> successful completion
173   -; -1 -> error
174   -; -2 -> end of file
175   -;
176   -; EXAMPLES:
177   -; (1) Read a FITS primary array:
178   -; a = mrdfits('TEST.FITS') or
179   -; a = mrdfits('TEST.FITS', 0, header)
180   -; The second example also retrieves header information.
181   -;
182   -; (2) Read rows 10-100 of the second extension of a FITS file.
183   -; a = mrdfits('TEST.FITS', 2, header, range=[10,100])
184   -;
185   -; (3) Read a table and ask that any scalings be applied and the
186   -; scaled data be converted to doubles. Use simple column names,
187   -; suppress outputs.
188   -; a = mrdfits('TEST.FITS', 1, /dscale, /use_colnum, /silent)
189   -;
190   -; (4) Read rows 3, 34 and 52 of a binary table and request that
191   -; variable length columns be stored as a pointer variable in the
192   -; output structure
193   -; a = mrdfits('TEST.FITS',1,rows=[3,34,52],/POINTER)
194   -
195   -; RESTRICTIONS:
196   -; (1) Cannot handle data in non-standard FITS formats.
197   -; (2) Doesn't do anything with BLANK or NULL values or
198   -; NaN's. They are just read in. They may be scaled
199   -; if scaling is applied.
200   -; NOTES:
201   -; This multiple format FITS reader is designed to provide a
202   -; single, simple interface to reading all common types of FITS data.
203   -; MRDFITS DOES NOT scale data by default. The FSCALE or DSCALE
204   -; parameters must be used.
205   -;
206   -; MRDFITS support 64 bit integer data types, which are tentatively
207   -; included in the FITS standard.
208   -; http://fits.gsfc.nasa.gov/fits_64bit.html
209   -;
210   -;
211   -; PROCEDURES USED:
212   -; The following procedures are contained in the main MRDFITS program.
213   -; MRD_IMAGE -- Generate array/structure for images.
214   -; MRD_READ_IMAGE -- Read image data.
215   -; MRD_ASCII -- Generate structure for ASCII tables.
216   -; MRD_READ_ASCII -- Read an ASCII table.
217   -; MRD_TABLE -- Generate structure for Binary tables.
218   -; MRD_READ_TABLE -- Read binary table info.
219   -; MRD_READ_HEAP -- Read variable length record info.
220   -; MRD_SCALE -- Apply scaling to data.
221   -; MRD_COLUMNS -- Extract columns.
222   -;
223   -; Other ASTRON Library routines used
224   -; FXPAR(), FXADDPAR, FXPOSIT, FXMOVE(), MRD_STRUCT(), MRD_SKIP,
225   -;
226   -; MODIfICATION HISTORY:
227   -; V1.0 November 9, 1994 ---- Initial release.
228   -; Creator: Thomas A. McGlynn
229   -; V1.1 January 20, 1995 T.A. McGlynn
230   -; Fixed bug in variable length records.
231   -; Added TDIM support -- new routine mrd_tdim in MRD_TABLE.
232   -; V1.2
233   -; Added support for dynamic decompression of files.
234   -; Fixed further bugs in variable length record handling.
235   -; V1.2a
236   -; Added NO_TDIM keyword to turn off TDIM processing for
237   -; those who don't want it.
238   -; Bug fixes: Handle one row tables correctly, use BZERO rather than
239   -; BOFFSET. Fix error in scaling of images.
240   -; V1.2b
241   -; Changed MRD_HREAD to handle null characters in headers.
242   -; V2.0 April 1, 1996
243   -; -Handles FITS tables with an arbitrary number of columns.
244   -; -Substantial changes to MRD_STRUCT to allow the use of
245   -; substructures when more than 127 columns are desired.
246   -; -All references to table columns are now made through the
247   -; functions MRD_GETC and MRD_PUTC. See description above.
248   -; -Use of SILENT will now eliminate compilation messages for
249   -; temporary functions.
250   -; -Bugs in handling of variable length columns with either
251   -; a single row in the table or a maximum of a single element
252   -; in the column fixed.
253   -; -Added support for DCOMPLEX numbers in binary tables (M formats) for
254   -; IDL versions above 4.0.
255   -; -Created regression test procedure to check in new versions.
256   -; -Added error_action parameter to allow user to specify
257   -; on_error action. This should allow better interaction with
258   -; new CHECK facility. ON_ERROR statements deleted from
259   -; most called routines.
260   -; - Modified MRDFITS to read in headers containing null characters
261   -; with a warning message printed.
262   -; V2.0a April 16, 1996
263   -; - Added IS_IEEE_BIG() checks (and routine) so that we don't
264   -; worry about IEEE to host conversions if the machine's native
265   -; format is IEEE Big-endian.
266   -; V2.1 August 24, 1996
267   -; - Use resolve_routine for dynamically defined functions
268   -; for versions > 4.0
269   -; - Fix some processing in random groups format.
270   -; - Handle cases where the data segment is--legally--null.
271   -; In this case MRDFITS returns a scalar 0.
272   -; - Fix bugs with the values for BSCALE and BZERO (and PSCAL and
273   -; PZERO) parameters set by MRDFITS.
274   -; V2.1a April 24, 1997 Handle binary tables with zero length columns
275   -; V2.1b May 13,1997 Remove whitespace from replicate structure definition
276   -; V2.1c May 28,1997 Less strict parsing of XTENSION keyword
277   -; V2.1d June 16, 1997 Fixed problem for >32767 entries introduced 24-Apr
278   -; V2.1e Aug 12, 1997 Fixed problem handling double complex arrays
279   -; V2.1f Oct 22, 1997 IDL reserved words can't be structure tag names
280   -; V2.1g Nov 24, 1997 Handle XTENSION keywords with extra blanks.
281   -; V2.1h Jul 26, 1998 More flexible parsing of TFORM characters
282   -; V2.2 Dec 14, 1998 Allow fields with longer names for
283   -; later versions of IDL.
284   -; Fix handling of arrays in scaling routines.
285   -; Allow >128 fields in structures for IDL >4.0
286   -; Use more efficient structure copying for
287   -; IDL>5.0
288   -; V2.2b June 17, 1999 Fix bug in handling case where
289   -; all variable length columns are deleted
290   -; because they are empty.
291   -; V2.3 March 7, 2000 Allow user to supply file handle rather
292   -; than file name.
293   -; Added status field.
294   -; Now needs FXMOVE routine
295   -; V2.3b April 4, 2000
296   -; Added compress option (from D. Palmer)
297   -; V2.4 July 4, 2000 Added STATUS=-1 for "File access error" (Zarro/GSFC)
298   -; V2.4a May 2, 2001 Trim binary format string (W. Landsman)
299   -; V2.5 December 5, 2001 Add unsigned, alias, 64 bit integers. version, $
300   -; /pointer_val, /fixed_var.
301   -; V2.5a Fix problem when both the first and the last character
302   -; in a TTYPEnn value are invalid structure tag characters
303   -; V2.6 February 15, 2002 Fix error in handling unsigned numbers, $
304   -; and 64 bit unsigneds. (Thanks to Stephane Beland)
305   -; V2.6a September 2, 2002 Fix possible conflicting data structure for
306   -; variable length arrays (W. Landsman)
307   -; V2.7 July, 2003 Added Rows keyword (W. Landsman)
308   -; V2.7a September 2003 Convert dimensions to long64 to handle huge files
309   -; V2.8 October 2003 Use IDL_VALIDNAME() function to ensure valid tag names
310   -; Removed OLD_STRUCT and TEMPDIR keywords W. Landsman
311   -; V2.9 February 2004 Added internal MRD_FXPAR procedure for faster
312   -; processing of binary table headers E. Sheldon
313   -; V2.9a March 2004 Restore ability to read empty binary table W. Landsman
314   -; Swallow binary tables with more columns than given in TFIELDS
315   -; V2.9b Fix to ensure order of TFORMn doesn't matter
316   -; V2.9c Check if extra degenerate NAXISn keyword are present W.L. Oct 2004
317   -; V2.9d Propagate /SILENT to MRD_HREAD, more LONG64 casting W. L. Dec 2004
318   -; V2.9e Add typarr[good] to fix a problem reading zero-length columns
319   -; A.Csillaghy, csillag@ssl.berkeley.edu (RHESSI)
320   -; V2.9f Fix problem with string variable binary tables, possible math
321   -; overflow on non-IEEE machines WL Feb. 2005
322   -; V2.9g Fix problem when setting /USE_COLNUM WL Feb. 2005
323   -; V2.10 Use faster keywords to BYTEORDER WL May 2006
324   -; V2.11 Add ON_IOERROR, CATCH, and STATUS keyword to MRD_READ_IMAGE to
325   -; trap EOF in compressed files DZ Also fix handling of unsigned
326   -; images when BSCALE not present K Chu/WL June 2006
327   -; V2.12 Allow extension to be specified by name, added EXTNUM keyword
328   -; WL December 2006
329   -; V2.12a Convert ASCII table column to DOUBLE if single precision is
330   -; insufficient
331   -; V2.12b Fixed problem when both /fscale and /unsigned are set
332   -; C. Markwardt Aug 2007
333   -; V2.13 Use SWAP_ENDIAN_INPLACE instead of IEEE_TO_HOST and IS_IEEE_BIG
334   -; W. Landsman Nov 2007
335   -; V2.13a One element vector allowed for file name W.L. Dec 2007
336   -;-
337   -PRO mrd_fxpar, hdr, xten, nfld, nrow, rsize, fnames, fforms, scales, offsets
338   -;
339   -; Check for valid header. Check header for proper attributes.
340   -;
341   - S = SIZE(HDR)
342   - IF ( S[0] NE 1 ) OR ( S[2] NE 7 ) THEN $
343   - MESSAGE,'FITS Header (first parameter) must be a string array'
344   -
345   - xten = fxpar(hdr, 'XTENSION')
346   - nfld = fxpar(hdr, 'TFIELDS')
347   - nrow = long64(fxpar(hdr, 'NAXIS2'))
348   - rsize = long64(fxpar(hdr, 'NAXIS1'))
349   -
350   - ;; will extract these for each
351   - names = ['TTYPE','TFORM', 'TSCAL', 'TZERO']
352   - nnames = n_elements(names)
353   -
354   -; Start by looking for the required TFORM keywords. Then try to extract it
355   -; along with names (TTYPE), scales (TSCAL), and offsets (TZERO)
356   -
357   - keyword = STRMID( hdr, 0, 8)
358   -
359   -;
360   -; Find all instances of 'TFORM' followed by
361   -; a number. Store the positions of the located keywords in mforms, and the
362   -; value of the number field in n_mforms
363   -;
364   -
365   - mforms = WHERE(STRPOS(keyword,'TFORM') GE 0, n_mforms)
366   - if n_mforms GT nfld then begin
367   - message,/CON, $
368   - 'WARNING - More columns found in binary table than specified in TFIELDS'
369   - n_mforms = nfld
370   - mforms = mforms[0:nfld-1]
371   - endif
372   -
373   -
374   - IF ( n_mforms GT 0 ) THEN BEGIN
375   - numst= STRMID(hdr[mforms], 5 ,3)
376   - number = INTARR(n_mforms)-1
377   -
378   - FOR i = 0, n_mforms-1 DO $
379   - IF VALID_NUM( numst[i], num) THEN number[i] = num
380   -
381   - igood = WHERE(number GE 0, n_mforms)
382   - IF n_mforms GT 0 THEN BEGIN
383   - mforms = mforms[igood]
384   - number = number[igood]
385   - numst = numst[igood]
386   - ENDIF
387   -
388   - ENDIF ELSE RETURN ;No fields in binary table
389   -
390   - ;; The others
391   - fnames = strarr(n_mforms)
392   - fforms = strarr(n_mforms)
393   - scales = dblarr(n_mforms)
394   - offsets = dblarr(n_mforms)
395   -
396   - ;;comments = strarr(n_mnames)
397   -
398   - fnames_names = 'TTYPE'+numst
399   - scales_names = 'TSCAL'+numst
400   - offsets_names = 'TZERO'+numst
401   - number = number -1 ;Make zero-based
402   -
403   -
404   - match, keyword, fnames_names, mkey_names, mnames, count = N_mnames
405   -
406   - match, keyword, scales_names, mkey_scales, mscales, count = N_mscales
407   -
408   - match, keyword, offsets_names, mkey_offsets, moffsets,count = N_moffsets
409   -
410   - FOR in=0L, nnames-1 DO BEGIN
411   -
412   - CASE names[in] OF
413   - 'TTYPE': BEGIN
414   - tmatches = mnames
415   - matches = mkey_names
416   - nmatches = n_mnames
417   - result = fnames
418   - END
419   - 'TFORM': BEGIN
420   - tmatches = lindgen(n_mforms)
421   - matches = mforms
422   - nmatches = n_mforms
423   - result = fforms
424   - END
425   - 'TSCAL': BEGIN
426   - tmatches = mscales
427   - matches = mkey_scales
428   - nmatches = n_mscales
429   - result = scales
430   - END
431   - 'TZERO': BEGIN
432   - tmatches = moffsets
433   - matches = mkey_offsets
434   - nmatches = n_moffsets
435   - result = offsets
436   - END
437   - ELSE: message,'What?'
438   - ENDCASE
439   -
440   - ;;help,matches,nmatches
441   -
442   -;
443   -; Extract the parameter field from the specified header lines. If one of the
444   -; special cases, then done.
445   -;
446   - IF nmatches GT 0 THEN BEGIN
447   -
448   - ;; "matches" is a subscript for hdr and keyword.
449   - ;; get just the matches in line
450   -
451   - line = hdr[matches]
452   - svalue = STRTRIM( STRMID(line,9,71),2)
453   -
454   - FOR i = 0, nmatches-1 DO BEGIN
455   - IF ( STRMID(svalue[i],0,1) EQ "'" ) THEN BEGIN
456   -
457   - ;; Its a string
458   - test = STRMID( svalue[i],1,STRLEN( svalue[i] )-1)
459   - next_char = 0
460   - off = 0
461   - value = ''
462   -;
463   -; Find the next apostrophe.
464   -;
465   -NEXT_APOST:
466   - endap = STRPOS(test, "'", next_char)
467   - IF endap LT 0 THEN MESSAGE, $
468   - 'WARNING: Value of '+nam+' invalid in '+ " (no trailing ')", /info
469   - value = value + STRMID( test, next_char, endap-next_char )
470   -;
471   -; Test to see if the next character is also an apostrophe. If so, then the
472   -; string isn't completed yet. Apostrophes in the text string are signalled as
473   -; two apostrophes in a row.
474   -;
475   - IF STRMID( test, endap+1, 1) EQ "'" THEN BEGIN
476   - value = value + "'"
477   - next_char = endap+2
478   - GOTO, NEXT_APOST
479   - ENDIF
480   -
481   -;
482   -; CM 19 Sep 1997
483   -; This is a string that could be continued on the next line. Check this
484   -; possibility with the following four criteria: *1) Ends with '&'
485   -; (2) Next line is CONTINUE (3) LONGSTRN keyword is present (recursive call to
486   -; FXPAR) 4. /NOCONTINE is not set
487   -
488   -;
489   -; If not a string, then separate the parameter field from the comment field.
490   -;
491   - ENDIF ELSE BEGIN
492   - ;; not a string
493   - test = svalue[I]
494   - slash = STRPOS(test, "/")
495   - IF slash GT 0 THEN BEGIN
496   - test = STRMID(test, 0, slash)
497   - END
498   -;
499   -; Find the first word in TEST. Is it a logical value ('T' or 'F')?
500   -;
501   - test2 = test
502   - value = GETTOK(test2,' ')
503   - test2 = STRTRIM(test2,2)
504   - IF ( value EQ 'T' ) THEN BEGIN
505   - value = 1
506   - END ELSE IF ( value EQ 'F' ) THEN BEGIN
507   - value = 0
508   - END ELSE BEGIN
509   -;
510   -; Test to see if a complex number. It's a complex number if the value and the
511   -; next word, if any, both are valid numbers.
512   -;
513   - IF STRLEN(test2) EQ 0 THEN GOTO, NOT_COMPLEX
514   - test2 = GETTOK(test2,' ')
515   - IF VALID_NUM(value,val1) AND VALID_NUM(value2,val2) $
516   - THEN BEGIN
517   - value = COMPLEX(val1,val2)
518   - GOTO, GOT_VALUE
519   - ENDIF
520   -;
521   -; Not a complex number. Decide if it is a floating point, double precision,
522   -; or integer number. If an error occurs, then a string value is returned.
523   -; If the integer is not within the range of a valid long value, then it will
524   -; be converted to a double.
525   -;
526   -NOT_COMPLEX:
527   - ON_IOERROR, GOT_VALUE
528   - value = test
529   - IF NOT VALID_NUM(value) THEN GOTO, GOT_VALUE
530   -
531   - IF (STRPOS(value,'.') GE 0) OR (STRPOS(value,'E') $
532   - GE 0) OR (STRPOS(value,'D') GE 0) THEN BEGIN
533   - IF ( STRPOS(value,'D') GT 0 ) OR $
534   - ( STRLEN(value) GE 8 ) THEN BEGIN
535   - value = DOUBLE(value)
536   - END ELSE value = FLOAT(value)
537   - ENDIF ELSE BEGIN
538   - lmax = 2.0D^31 - 1.0D
539   - lmin = -2.0D31
540   - value = DOUBLE(value)
541   - if (value GE lmin) and (value LE lmax) THEN $
542   - value = LONG(value)
543   - ENDELSE
544   -
545   -;
546   -GOT_VALUE:
547   - ON_IOERROR, NULL
548   - ENDELSE
549   - ENDELSE ; if string
550   -;
551   -; Add to vector if required.
552   -;
553   -
554   - result[tmatches[i]] = value
555   -
556   - ENDFOR
557   -
558   - CASE names[in] OF
559   - 'TTYPE': fnames[number] = strtrim(result, 2)
560   - 'TFORM': fforms[number] = strtrim(result, 2)
561   - 'TSCAL': scales[number] = result
562   - 'TZERO': offsets[number] = result
563   - ELSE: message,'What?'
564   - ENDCASE
565   -
566   -;
567   -; Error point for keyword not found.
568   -;
569   - ENDIF
570   -;
571   -
572   -
573   -
574   - ENDFOR
575   -END
576   -
577   -
578   -; Get a tag name give the column name and index
579   -function mrd_dofn, name, index, use_colnum, alias=alias
580   -
581   - ; Check if the user has specified an alias.
582   -
583   - if n_elements(name) eq 0 then name = 'C'+strtrim(index, 2)
584   - name = strtrim(name)
585   - if keyword_set(alias) then begin
586   - sz = size(alias)
587   -
588   - if (sz[0] eq 1 or sz[0] eq 2) and sz[1] eq 2 and sz[sz[0]+1] eq 7 then begin
589   - w=where(name eq alias[1,*])
590   - if (w[0] ne -1) then begin
591   - name = alias[0,w[0]];
592   - endif
593   - endif
594   - endif
595   - ; Convert the string name to a valid variable name. If name
596   - ; is not defined generate the string Cnn when nn is the index
597   - ; number.
598   -
599   - table = 0
600   - sz = size(name)
601   - nsz = n_elements(sz)
602   - if not use_colnum and (sz[nsz-2] ne 0) then begin
603   - if sz[nsz-2] eq 7 then begin
604   - str = name[0]
605   - endif else begin
606   - str = 'C'+strtrim(index,2)
607   - endelse
608   - endif else begin
609   - str = 'C'+strtrim(index,2)
610   - endelse
611   -
612   - return, IDL_VALIDNAME(str,/CONVERT_ALL)
613   -
614   -end
615   -
616   -;***************************************************************
617   -
618   -
619   -
620   -; Parse the TFORM keyword and return the type and dimension of the
621   -; data.
622   -pro mrd_doff, form, dim, type
623   -
624   - ; Find the first non-numeric character.
625   -
626   - len = strlen(form)
627   -
628   - if len le 0 then return
629   -
630   - for i=0, len-1 do begin
631   -
632   - c = strmid(form, i, 1)
633   - if c lt '0' or c gt '9' then goto, not_number
634   -
635   - endfor
636   -
637   - not_number:
638   -
639   - if i ge len then return ;Modified from len-1 on 26-Jul-1998
640   -
641   - if i gt 0 then begin
642   - dim = long(strmid(form, 0, i))
643   - if dim EQ 0l then dim = -1l
644   - endif else begin
645   - dim = 0
646   - endelse
647   -
648   - type = strmid(form, i, 1)
649   -end
650   -
651   -
652   -
653   -;*********************************************************************
654   -
655   -; Check that this name is unique with regard to other column names.
656   -
657   -function mrd_chkfn, name, namelist, index
658   -
659   - ;
660   - ;
661   -
662   - maxlen = 127
663   -
664   - if strlen(name) gt maxlen then name = strmid(name, 0, maxlen)
665   - w = where(name eq strmid(namelist, 0, maxlen) )
666   - if w[0] ne -1 then begin
667   - ; We have found a name conflict.
668   - ;
669   - name = 'gen$name_'+strcompress(string(index+1),/remove_all)
670   - endif
671   -
672   - return, name
673   -
674   -end
675   -
676   -; Find the appropriate offset for a given unsigned type.
677   -; The type may be given as the bitpix value or the IDL
678   -; variable type.
679   -
680   -function mrd_unsigned_offset, type
681   -
682   - if (type eq 12 or type eq 16) then begin
683   - return, uint(32768)
684   - endif else if (type eq 13 or type eq 32) then begin
685   - return, ulong('2147483648')
686   - endif else if (type eq 15 or type eq 64) then begin
687   - return, ulong64('9223372036854775808');
688   - endif
689   - return, 0
690   -end
691   -
692   -
693   -
694   -; Can we treat this data as unsigned?
695   -
696   -function mrd_chkunsigned, bitpix, scale, zero, unsigned=unsigned
697   -
698   - if not keyword_set(unsigned) then return, 0
699   -
700   - ; This is correct but we should note that
701   - ; FXPAR returns a double rather than a long.
702   - ; Since the offset is a power of two
703   - ; it is an integer that is exactly representable
704   - ; as a double. However, if a user were to use
705   - ; 64 bit integers and an offset close to but not
706   - ; equal to 2^63, we would erroneously assume that
707   - ; the dataset was unsigned...
708   -
709   -
710   - if scale eq 1 then begin
711   - if (bitpix eq 16 and zero eq 32768L) or $
712   - (bitpix eq 32 and zero eq ulong('2147483648')) or $
713   - (bitpix eq 64 and zero eq ulong64('9223372036854775808')) then begin
714   - return, 1
715   - endif
716   - endif
717   - return, 0
718   -end
719   -
720   -; Is this one of the IDL unsigned types?
721   -function mrd_unsignedtype, data
722   -
723   - type = size(data,/ type)
724   - if (type eq 12) or (type eq 13) or (type eq 15) then return, type $
725   - else return, 0
726   -
727   -end
728   -
729   -; Return the currrent version string for MRDFITS
730   -function mrd_version
731   - return, '2.13a'
732   -end
733   -;=====================================================================
734   -; END OF GENERAL UTILITY FUNCTIONS ===================================
735   -;=====================================================================
736   -
737   -
738   -; Parse the TFORM keyword and return the type and dimension of the
739   -; data.
740   -pro mrd_atype, form, type, slen
741   -
742   -
743   - ; Find the first non-numeric character.
744   -
745   -
746   - ; Get rid of blanks.
747   - form = strcompress(form,/remove_all)
748   - len = strlen(form)
749   - if len le 0 then return
750   -
751   - type = strmid(form, 0,1)
752   - length = strmid(form,1,len-1)
753   - ;
754   - ; Ignore the number of decimal places. We assume that there
755   - ; is a decimal point.
756   - ;
757   - p = strpos(length, '.')
758   - if p gt 0 then length = strmid(length,0,p)
759   -
760   - if strlen(length) gt 0 then slen = fix(length) else slen = 1
761   - if (type EQ 'F') or (type EQ 'E') then $ ;Updated April 2007
762   - if (slen GE 8) then type = 'D'
763   -
764   -end
765   -
766   -
767   -; Read in the table information.
768   -pro mrd_read_ascii, unit, range, nbytes, nrows, nfld, typarr, posarr, $
769   - lenarr, nullarr, table, old_struct=old_struct, rows=rows
770   -
771   - ;
772   - ; Unit Unit to read data from.
773   - ; Range Range of to be read
774   - ; Nbytes Number of bytes per row.
775   - ; Nrows Number of rows.
776   - ; Nfld Number of fields in structure.
777   - ; Typarr Array indicating type of variable.
778   - ; Posarr Starting position of fields (first char at 0)
779   - ; Lenarr Length of fields
780   - ; Nullarr Array of null values
781   - ; Table Table to read information into.
782   - ; Old_struct Should recursive structure format be used?
783   -
784   - bigstr = bytarr(nbytes, range[1]-range[0]+1)
785   -
786   - if range[0] gt 0 then mrd_skip, unit, nbytes*range[0]
787   - readu,unit, bigstr
788   - if N_elements(rows) GT 0 then bigstr = bigstr[*,rows-range[0]]
789   -
790   - ; Skip to the end of the data area.
791   -
792   - nSkipRow = nrows - range[1] - 1
793   - nskipB = 2880 - (nbytes*nrows) mod 2880
794   - if nskipB eq 2880 then nskipB = 0
795   -
796   - mrd_skip, unit, nskipRow*nbytes+nskipB
797   -
798   - s1 = posarr-1
799   - s2 = s1 + lenarr - 1
800   - for i=0, nfld-1 do begin
801   -
802   - flds = strtrim( bigstr[s1[i]:s2[i],* ] )
803   -
804   - if strtrim(nullarr[i]) ne '' then begin
805   -
806   - curr_col = table.(i)
807   -
808   - w = where(flds ne strtrim(nullarr[i]))
809   - if w[0] ne -1 then begin
810   - if N_elements(w) EQ 1 then w = w[0]
811   - if typarr[i] eq 'I' then begin
812   - curr_col[w] = long(flds[w])
813   - endif else if typarr[i] eq 'E' or typarr[i] eq 'F' then begin
814   - curr_col[w] = float(flds[w])
815   - endif else if typarr[i] eq 'D' then begin
816   - curr_col[w] = double(flds[w])
817   - endif else if typarr[i] eq 'A' then begin
818   - curr_col[w] = flds[w]
819   - endif
820   - endif
821   -
822   - table.(i) = curr_col
823   -
824   - endif else begin
825   -
826   -
827   -
828   - if typarr[i] eq 'I' then begin
829   - table.(i) = long(flds)
830   - endif else if typarr[i] eq 'E' or typarr[i] eq 'F' then begin
831   - table.(i) = float(flds)
832   - endif else if typarr[i] eq 'D' then begin
833   - table.(i) = double(flds)
834   - endif else if typarr[i] eq 'A' then begin
835   - table.(i) = flds
836   - endif
837   - endelse
838   - endfor
839   -
840   -end
841   -
842   -
843   -; Define a structure to hold a FITS ASCII table.
844   -pro mrd_ascii, header, structyp, use_colnum, $
845   - range, table, $
846   - nbytes, nrows, nfld, typarr, posarr, lenarr, nullarr, $
847   - fnames, fvalues, scales, offsets, scaling, status, rows = rows, $
848   - silent=silent, columns=columns, alias=alias
849   -
850   - ;
851   - ; Header FITS header for table.
852   - ; Structyp IDL structure type to be used for
853   - ; structure.
854   - ; Use_colnum Use column numbers not names.
855   - ; Range Range of rows of interest
856   - ; Table Structure to be defined.
857   - ; Nbytes Bytes per row
858   - ; Nrows Number of rows in table
859   - ; Nfld Number of fields
860   - ; Typarr Array of field types
861   - ; Posarr Array of field offsets
862   - ; Lenarr Array of field lengths
863   - ; Nullarr Array of field null values
864   - ; Fname Column names
865   - ; Fvalues Formats for columns
866   - ; Scales/offsets Scaling factors for columns
867   - ; Scaling Do we need to scale?
868   - ; Status Return status.
869   -
870   - table = 0
871   -
872   - types = ['I', 'E', 'F', 'D', 'A']
873   - sclstr = ['0l', '0.0', '0.0', '0.0d0', ' ']
874   - status = 0
875   -
876   - if strmid(fxpar(header, 'XTENSION'),0,8) ne 'TABLE ' then begin
877   - print, 'MRDFITS: Header is not from ASCII table.'
878   - status = -1;
879   - return
880   - endif
881   -
882   - nfld = fxpar(header, 'TFIELDS')
883   - nrows = long64( fxpar(header, 'NAXIS2'))
884   - nbytes = long64( fxpar(header, 'NAXIS1'))
885   -
886   - if range[0] ge 0 then begin
887   - range[0] = range[0] < (nrows-1)
888   - range[1] = range[1] < (nrows-1)
889   - endif else begin
890   - range[0] = 0
891   - range[1] = nrows-1
892   - endelse
893   -
894   - if N_elements(rows) EQ 0 then nrows = range[1] - range[0] + 1 else begin
895   - bad = where(rows GT nrows, Nbad)
896   - if Nbad GT 0 then begin
897   - print,'MRDFITS: Row numbers must be between 0 and ' + $
898   - strtrim(nrows-1,2)
899   - status = -1
900   - return
901   - endif
902   - nrows = N_elements(rows)
903   - endelse
904   -
905   - if nrows le 0 then begin
906   - if not keyword_set(silent) then begin
907   - print,'MRDFITS: ASCII table. ',strcompress(string(nfld)), $
908   - ' columns, no rows'
909   - endif
910   - return
911   - endif
912   -
913   - ;
914   - ; Loop over the columns
915   -
916   - typarr = strarr(nfld)
917   - lenarr = intarr(nfld)
918   - posarr = intarr(nfld)
919   - nullarr = strarr(nfld)
920   - fnames = strarr(nfld)
921   - fvalues = strarr(nfld)
922   - scales = dblarr(nfld)
923   - offsets = dblarr(nfld)
924   -
925   -
926   - for i=0, nfld-1 do begin
927   - suffix = strcompress(string(i+1), /remove_all)
928   - fname = fxpar(header, 'TTYPE' + suffix, count=cnt)
929   - if cnt eq 0 then xx = temporary(fname)
930   - fform = fxpar(header, 'TFORM' + suffix)
931   - fpos = fxpar(header, 'TBCOL' + suffix)
932   - fnull = fxpar(header, 'TNULL' + suffix, count=cnt)
933   - if cnt eq 0 then fnull = ''
934   - scales[i] = fxpar(header, 'TSCAL' + suffix)
935   - if scales[i] eq 0.0d0 then scales[i] = 1.0d0
936   - offsets[i] = fxpar(header, 'TZERO'+suffix)
937   -
938   - fname = mrd_dofn(fname,i+1, use_colnum, alias=alias)
939   - fnames[i] = fname
940   -
941   - fname = mrd_chkfn(fname, fnames, i)
942   -
943   - mrd_atype, fform, ftype, flen
944   - typarr[i] = ftype
945   - lenarr[i] = flen
946   - posarr[i] = fpos
947   - nullarr[i] = fnull
948   -
949   - for j=0, n_elements(types) - 1 do begin
950   - if ftype eq types[j] then begin
951   - if ftype ne 'A' then begin
952   - val = sclstr[j]
953   - endif else begin
954   - val = 'string(replicate(32b,'+strtrim(flen,2)+'))'
955   - endelse
956   -
957   - fvalues[i] = val
958   -
959   - goto, next_col
960   - endif
961   - endfor
962   -
963   - print, 'MRDFITS: Invalid format code:',ftype, ' for column ', i+1
964   - status = -1
965   - return
966   - next_col:
967   - endfor
968   -
969   - if scaling then begin
970   - w = where(scales ne 1.0d0 or offsets ne 0.0d0)
971   - if w[0] eq -1 then scaling = 0
972   - endif
973   -
974   - if not scaling and not keyword_set(columns) then begin
975   - table = mrd_struct(fnames, fvalues, nrows, structyp=structyp, $
976   - silent=silent)
977   - endif else begin
978   - table = mrd_struct(fnames, fvalues, nrows, silent=silent)
979   - endelse
980   -
981   - if not keyword_set(silent) then begin
982   - print,'MRDFITS: ASCII table. ',strcompress(string(nfld)), $
983   - ' columns by ',strcompress(string(nrows)), ' rows.'
984   - endif
985   -
986   - status = 0
987   - return
988   -
989   -end
990   -
991   -
992   -; Eliminate columns from the table that do not match the
993   -; user specification.
994   -pro mrd_columns, table, columns, fnames, fvalues, $
995   - vcls, vtpes, scales, offsets, scaling, $
996   - structyp=structyp, silent=silent
997   -
998   -
999   -
1000   - sz = size(columns)
1001   -
1002   - type = sz[sz[0]+1]
1003   - nele = sz[sz[0]+2]
1004   - if type eq 8 or type eq 6 or type eq 0 then return ; Can't use structs
1005   - ; or complex.
1006   -
1007   - if type eq 4 or type eq 5 then tcols = fix(columns)
1008   - if type eq 1 or type eq 2 or type eq 3 then tcols = columns
1009   -
1010   - ; Convert strings to uppercase and compare with column names.
1011   -
1012   - if type eq 7 then begin
1013   - for i=0, nele-1 do begin
1014   - cname = strupcase(columns[i])
1015   - w = where(cname eq strupcase(fnames))
1016   - if w[0] ne -1 then begin
1017   - if n_elements(tcols) eq 0 then begin
1018   - tcols = w[0]+1
1019   - endif else begin
1020   - tcols = [tcols, w[0]+1]
1021   - endelse
1022   - endif
1023   - endfor
1024   - endif
1025   -
1026   - ; Subtract one from column indices and check that all indices >= 0.
1027   - if n_elements(tcols) gt 0 then begin
1028   - tcols = tcols-1
1029   - w = where(tcols ge 0)
1030   - if w[0] eq -1 then begin
1031   - dummy = temporary(tcols)
1032   - endif
1033   - endif
1034   -
1035   - if n_elements(tcols) le 0 then begin
1036   - print, 'MRDFITS: No columns match'
1037   -
1038   - ; Undefine variables. First ensure they are defined, then
1039   - ; use temporary() to undefine them.
1040   - table = 0
1041   - fnames = 0
1042   - fvalues = 0
1043   - vcls = 0
1044   - vtpes = 0
1045   - scales = 0
1046   - offsets = 0
1047   - dummy = temporary(fnames)
1048   - dummy = temporary(fvalues)
1049   - dummy = temporary(vcls)
1050   - dummy = temporary(vtpes)
1051   - dummy = temporary(scales)
1052   - dummy = temporary(offsets)
1053   - scaling = 0
1054   -
1055   - endif else begin
1056   -
1057   - ; Replace arrays with only desired columns.
1058   -
1059   - fnames = fnames[tcols]
1060   - fvalues = fvalues[tcols]
1061   -
1062   - ; Check if there are still variable length columns.
1063   - if n_elements(vcls) gt 0 then begin
1064   - vcls = vcls[tcols]
1065   - vtpes = vtpes[tcols]
1066   - w = where(vcls eq 1)
1067   - if w[0] eq -1 then begin
1068   - dummy = temporary(vcls)
1069   - dummy = temporary(vtpes)
1070   - endif
1071   - endif
1072   -
1073   - ; Check if there are still columns that need scaling.
1074   - if n_elements(scales) gt 0 then begin
1075   - scales = scales[tcols]
1076   - offsets = offsets[tcols]
1077   - w = where(scales ne 1.0d0 or offsets ne 0.0d0)
1078   - if w[0] eq -1 then scaling = 0
1079   - endif
1080   -
1081   -
1082   - ndim = n_elements(table)
1083   -
1084   - if scaling or n_elements(vcls) gt 0 then begin
1085   - tabx = mrd_struct(fnames, fvalues, ndim, silent=silent )
1086   - endif else begin
1087   - tabx = mrd_struct(fnames, fvalues, ndim, structyp=structyp, silent=silent )
1088   - endelse
1089   -
1090   - for i=0, n_elements(tcols)-1 do begin
1091   - tabx.(i) = table.(tcols[i]);
1092   - endfor
1093   -
1094   - table = tabx
1095   - endelse
1096   -
1097   -end
1098   -
1099   -
1100   -; Read in the image information.
1101   -pro mrd_read_image, unit, range, maxd, rsize, table, rows = rows,status=status
1102   -
1103   - ;
1104   - ; Unit Unit to read data from.
1105   - ; Table Table/array to read information into.
1106   - ;
1107   -
1108   - error=0
1109   - catch,error
1110   - if error ne 0 then begin
1111   - catch,/cancel
1112   - status=-2
1113   - return
1114   - endif
1115   -
1116   - ; If necessary skip to beginning of desired data.
1117   -
1118   - if range[0] gt 0 then mrd_skip, unit, range[0]*rsize
1119   -
1120   - status=-2
1121   - if rsize eq 0 then return
1122   -
1123   - on_ioerror,done
1124   - readu, unit, table
1125   -
1126   - if N_elements(rows) GT 0 then begin
1127   - row1 = rows- range[0]
1128   - case size(table,/n_dimen) of
1129   - 1: table = table[row1]
1130   - 2: table = table[*,row1]
1131   - 3: table = table[*,*,row1]
1132   - 4: table = table[*,*,*,row1]
1133   - 5: table = table[*,*,*,*,row1]
1134   - 6: table = table[*,*,*,*,*,row1]
1135   - 7: table = table[*,*,*,*,*,*,row1]
1136   - 8: table = table[*,*,*,*,*,*,*,row1]
1137   - else: begin
1138   - print,'MRDFITS: Subscripted image must be between 1 and 8 dimensions'
1139   - status = -1
1140   - return
1141   - end
1142   - endcase
1143   - endif
1144   -
1145   - ; Skip to the end of the data
1146   -
1147   - skipB = 2880 - (maxd*rsize) mod 2880
1148   - if skipB eq 2880 then skipB = 0
1149   -
1150   - if range[1] lt maxd-1 then begin
1151   - skipB = skipB + (maxd-range[1]-1)*rsize
1152   - endif
1153   -
1154   - mrd_skip, unit, skipB
1155   - swap_endian_inplace, table,/swap_if_little
1156   -
1157   - ; Fix offset for unsigned data
1158   - type = mrd_unsignedtype(table)
1159   - if type gt 0 then begin
1160   - table = table - mrd_unsigned_offset(type)
1161   - endif
1162   -
1163   - status=0
1164   - done:
1165   -
1166   -;-- probably an EOF
1167   -
1168   - if status ne 0 then free_lun,unit
1169   -
1170   - return
1171   -end
1172   -
1173   -; Truncate superfluous axes.
1174   -
1175   -pro mrd_axes_trunc,naxis, dims, silent
1176   -
1177   - mysilent = silent
1178   - for i=naxis-1,1,-1 do begin
1179   -
1180   - if dims[i] eq 1 then begin
1181   - if not mysilent then begin
1182   - print, 'MRDFITS: Truncating unused dimensions'
1183   - mysilent = 1
1184   - endif
1185   - dims = dims[0:i-1]
1186   - naxis = naxis - 1
1187   -
1188   - endif else return
1189   -
1190   - endfor
1191   -
1192   - return
1193   -end
1194   -
1195   -; Define structure/array to hold a FITS image.
1196   -pro mrd_image, header, range, maxd, rsize, table, scales, offsets, scaling, $
1197   - status, silent=silent, unsigned=unsigned, rows = rows
1198   -
1199   - ;
1200   - ; Header FITS header for table.
1201   - ; Range Range of data to be retrieved.
1202   - ; Rsize Size of a row or group.
1203   - ; Table Structure to be defined.
1204   - ; Status Return status
1205   - ; Silent=silent Suppress info messages?
1206   -
1207   - table = 0
1208   -
1209   - ; type 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
1210   - lens = [ 0, 1, 2, 4, 4, 8, 0, 0, 0, 0, 0, 0, 2, 4, 8, 8]
1211   - typstrs=['', 'Byte', 'Int*2', 'Int*4', 'Real*4', 'Real*8','','','','','','', 'UInt*2', 'Uint*4', 'Int*8', 'Uint*8']
1212   - typarr= ['', 'bytarr', 'intarr', 'lonarr', 'fltarr', 'dblarr','','','','','','','uintarr', 'ulonarr', 'lon64arr', 'ulon64arr']
1213   -
1214   - status = 0
1215   -
1216   -
1217   - naxis = fxpar(header, 'NAXIS')
1218   - bitpix= fxpar(header, 'BITPIX')
1219   - if naxis gt 0 then begin
1220   - dims = long64(fxpar(header, 'NAXIS*', Count = N_axis))
1221   - if N_axis GT naxis then begin
1222   -; Check if extra NAXISn keywords are present (though this is not legal FITS)
1223   - nextra = N_axis - naxis
1224   - dim_extra = dims[naxis:N_axis-1]
1225   - if total(dim_extra) EQ nextra then $
1226   - dims = dims[0:naxis-1] else $
1227   - message,'ERROR - NAXIS = ' + strtrim(naxis,2) + $
1228   - ' but NAXIS' + strtrim(N_axis,2) + ' keyword present'
1229   - endif
1230   - endif else dims = 0
1231   -
1232   - gcount = fxpar(header, 'GCOUNT')
1233   - pcount = fxpar(header, 'PCOUNT')
1234   - isgroup = fxpar(header, 'GROUPS')
1235   - gcount = long(gcount)
1236   -
1237   - xscale = fxpar(header, 'BSCALE', count=cnt)
1238   - if cnt eq 0 then xscale = 1 ;Corrected 06/29/06
1239   -
1240   - xunsigned = mrd_chkunsigned(bitpix, xscale, $
1241   - fxpar(header, 'BZERO'), unsigned=unsigned)
1242   - ; Note that type is one less than the type signifier returned in the size call.
1243   - type = -1
1244   -
1245   - if not xunsigned then begin
1246   -
1247   - if bitpix eq 8 then type = 1 $
1248   - else if bitpix eq 16 then type = 2 $
1249   - else if bitpix eq 32 then type = 3 $
1250   - else if bitpix eq -32 then type = 4 $
1251   - else if bitpix eq -64 then type = 5 $
1252   - else if bitpix eq 64 then type = 14
1253   -
1254   - endif else begin
1255   -
1256   - if bitpix eq 16 then type = 12 $
1257   - else if bitpix eq 32 then type = 13 $
1258   - else if bitpix eq 64 then type = 15
1259   -
1260   - endelse
1261   -
1262   - if type eq -1 then begin
1263   - print,'MRDFITS: Error: Invalid BITPIX: '+strtrim(bitpix)
1264   - table = 0
1265   - return
1266   - endif
1267   -
1268   - ; Note that for random groups data we must ignore the first NAXISn keyword.
1269   - if isgroup GT 0 then begin
1270   -
1271   -
1272   - range[0] = range[0] > 0
1273   - if (range[1] eq -1) then begin
1274   - range[1] = gcount-1
1275   - endif else begin
1276   - range[1] = range[1] < gcount - 1
1277   - endelse
1278   -
1279   - maxd = gcount
1280   -
1281   - if (n_elements(dims) gt 1) then begin
1282   - dims = dims[1:*]
1283   - naxis = naxis-1
1284   - endif else begin
1285   - print, 'MRDFITS: Warning: No data specified for group data.'
1286   - dims = [0]
1287   - naxis = 0
1288   - endelse
1289   -
1290   - ; The last entry is the scaling for the sample data.
1291   -
1292   - if (pcount gt 0) then begin
1293   - scales = dblarr(pcount+1)
1294   - offsets = dblarr(pcount+1)
1295   - endif
1296   -
1297   - values = strarr(2)
1298   -
1299   -
1300   - mrd_axes_trunc, naxis, dims, keyword_set(silent)
1301   -
1302   - values[0] = typarr[type] + "("+string(pcount)+")"
1303   - rsize = dims[0]
1304   - sarr = "(" + strcompress(string(dims[0]), /remo )
1305   -
1306   - for i=1, naxis-1 do begin
1307   -
1308   - sarr = sarr + "," + strcompress(string(dims[i]),/remo)
1309   - rsize = rsize*dims[i]
1310   -
1311   - endfor
1312   -
1313   - sarr = sarr + ")"
1314   -
1315   - if not keyword_set(silent) then print,'MRDFITS--Image with groups:', $
1316   - ' Ngroup=',strcompress(string(gcount)),' Npar=', $
1317   - strcompress(string(pcount),/remo), ' Group=', sarr, ' Type=',typstrs[type]
1318   -
1319   - sarr = typarr[type] + sarr
1320   - values[1] = sarr
1321   - rsize = (rsize + pcount)*lens[type]
1322   -
1323   - table = mrd_struct(['params','array'], values, range[1]-range[0]+1, $
1324   - silent=silent)
1325   -
1326   - if xunsigned then begin
1327   - fxaddpar,header, 'BZERO', 0, 'Reset by MRDFITS v'+mrd_version()
1328   - endif
1329   -
1330   -
1331   - for i=0, pcount-1 do begin
1332   -
1333   - istr = strcompress(string(i+1),/remo)
1334   -
1335   - scales[i] = fxpar(header, 'PSCAL'+istr)
1336   - if scales[i] eq 0.0d0 then scales[i] =1.0d0
1337   -
1338   - offsets[i] = fxpar(header, 'PZERO'+istr)
1339   -
1340   - scales[pcount] = fxpar(header, 'BSCALE')
1341   - if scales[pcount] eq 0.0d0 then scales[pcount] = 1.0d0
1342   - offsets[pcount] = fxpar(header, 'BZERO')
1343   -
1344   - endfor
1345   -
1346   - if scaling then begin
1347   - w = where(scales ne 1.0d0 or offsets ne 0.0d0)
1348   - if w[0] eq -1 then scaling = 0
1349   - endif
1350   -
1351   - endif else begin
1352   -
1353   - if naxis eq 0 then begin
1354   -
1355   - rsize = 0
1356   - table = 0
1357   - if not keyword_set(silent) then begin
1358   - print, 'MRDFITS: Null image, NAXIS=0'
1359   - endif
1360   - return
1361   -
1362   - endif
1363   -
1364   - if gcount gt 1 then begin
1365   - dims = [dims, gcount]
1366   - naxis = naxis + 1
1367   - endif
1368   -
1369   - mrd_axes_trunc, naxis, dims, keyword_set(silent)
1370   -
1371   -
1372   - maxd = dims[naxis-1]
1373   -
1374   - if range[0] ne -1 then begin
1375   - range[0] = range[0]<(maxd-1)
1376   - range[1] = range[1]<(maxd-1)
1377   - endif else begin
1378   - range[0] = 0
1379   - range[1] = maxd - 1
1380   - endelse
1381   -
1382   - Nlast = dims[naxis-1]
1383   - dims[naxis-1] = range[1]-range[0]+1
1384   - pdims = dims
1385   - if N_elements(rows) GT 0 then begin
1386   - if max(rows) GE Nlast then begin
1387   - print, 'MRDFITS: Row numbers must be between 0 and ' + $
1388   - strtrim(Nlast-1,2)
1389   - status = -1 & rsize = 0
1390   - return
1391   - endif
1392   - pdims[naxis-1] = N_elements(rows)
1393   - endif
1394   -
1395   - if not keyword_set(silent) then begin
1396   - str = '('
1397   - for i=0, naxis-1 do begin
1398   - if i ne 0 then str = str + ','
1399   - str = str + strcompress(string(pdims[i]),/remo)
1400   - endfor
1401   - str = str+')'
1402   - print, 'MRDFITS: Image array ',str, ' Type=', typstrs[type]
1403   - endif
1404   -
1405   - rsize = 1
1406   -
1407   - if naxis gt 1 then for i=0, naxis - 2 do rsize=rsize*dims[i]
1408   - rsize = rsize*lens[type]
1409   - sz = lonarr(naxis+3)
1410   - sz[0] = naxis
1411   - sz[1:naxis] = dims
1412   - nele = 1l
1413   -
1414   - for i=0, naxis-1 do begin
1415   - nele = nele*dims[i]
1416   - endfor
1417   -
1418   - sz[naxis+1] = type
1419   - sz[naxis+2] = nele
1420   -
1421   - if nele gt 0 then begin
1422   - table = make_array(size=sz)
1423   - endif else begin
1424   - table = 0
1425   - endelse
1426   -
1427   - scales = dblarr(1)
1428   - offsets = dblarr(1)
1429   -
1430   - if xunsigned then begin
1431   - fxaddpar,header, 'BZERO', 0, 'Updated by MRDFITS v'+mrd_version()
1432   - endif
1433   -
1434   - scales[0] = fxpar(header, 'BSCALE')
1435   - offsets[0] = fxpar(header, 'BZERO')
1436   -
1437   - if scales[0] eq 0.0d0 then scales[0] = 1.0d0
1438   - if scaling and scales[0] eq 1.0d0 and offsets[0] eq 0.0d0 then scaling = 0
1439   - endelse
1440   -
1441   - status = 0
1442   - return
1443   -
1444   -end
1445   -
1446   -; Scale an array of pointers
1447   -pro mrd_ptrscale, array, scale, offset
1448   -
1449   - for i=0, n_elements(array)-1 do begin
1450   - if ptr_valid(array[i]) then begin
1451   - array[i] = ptr_new(*array[i] * scale + offset)
1452   - endif
1453   - endfor
1454   -end
1455   -
1456   -; Scale a FITS array or table.
1457   -pro mrd_scale, type, scales, offsets, table, header, $
1458   - fnames, fvalues, nrec, dscale = dscale, structyp=structyp, silent=silent
1459   - ;
1460   - ; Type: FITS file type, 0=image/primary array
1461   - ; 1=ASCII table
1462   - ; 2=Binary table
1463   - ;
1464   - ; scales: An array of scaling info
1465   - ; offsets: An array of offset information
1466   - ; table: The FITS data.
1467   - ; header: The FITS header.
1468   - ; dscale: Should data be scaled to R*8?
1469   - ; fnames: Names of table columns.
1470   - ; fvalues: Values of table columns.
1471   - ; nrec: Number of records used.
1472   - ; structyp: Structure name.
1473   -
1474   - w = where(scales ne 1.d0 or offsets ne 0.d0)
1475   - if w[0] eq -1 then return
1476   - ww = where(scales eq 1.d0 and offsets eq 0.d0)
1477   -
1478   - ; First do ASCII and Binary tables.
1479   - if type ne 0 then begin
1480   -
1481   - if type eq 1 then begin
1482   - if keyword_set(dscale) then begin
1483   - fvalues[w] = '0.0d0'
1484   - endif else begin
1485   - fvalues[w] = '0.0'
1486   - endelse
1487   - endif else if type eq 2 then begin
1488   -
1489   - if keyword_set(dscale) then begin
1490   - sclr = '0.d0'
1491   - vc = 'dblarr'
1492   - endif else begin
1493   - sclr = '0.0'
1494   - vc = 'fltarr'
1495   - endelse
1496   -
1497   - for i=0, n_elements(w)-1 do begin
1498   - col = w[i]
1499   - sz = size(table[0].(col))
1500   -
1501   - ; Handle pointer columns
1502   - if sz[sz[0]+1] eq 10 then begin
1503   - fvalues[col] = 'ptr_new()'
1504   -
1505   - ; Scalar columns
1506   - endif else if sz[0] eq 0 then begin
1507   - fvalues[col] = sclr
1508   -
1509   - ; Vectors
1510   - endif else begin
1511   - str = vc + '('
1512   - for j=0, sz[0]-1 do begin
1513   - if j ne 0 then str = str + ','
1514   - str = str + strtrim(sz[j+1],2)
1515   - endfor
1516   - str = str + ')'
1517   - fvalues[col] = str
1518   -
1519   - endelse
1520   -
1521   - endfor
1522   - endif
1523   -
1524   - tabx = mrd_struct(fnames, fvalues, nrec, structyp=structyp, silent=silent )
1525   -
1526   - ; Just copy the unscaled columns
1527   - if ww[0] ne -1 then begin
1528   -
1529   - for i=0, n_elements(ww)-1 do begin
1530   - tabx.(ww[i]) = table.(ww[i])
1531   - endfor
1532   - endif
1533   -
1534   - for i=0, n_elements(w)-1 do begin
1535   -
1536   -
1537   - sz = size(tabx.(w[i]))
1538   - if sz[sz[0]+1] eq 10 then begin
1539   - mrd_ptrscale, table.(w[i]), scales[w[i]], offsets[w[i]]
1540   - endif
1541   - tabx.(w[i]) = table.(w[i])*scales[w[i]] + offsets[w[i]]
1542   -
1543   - istr = strcompress(string(w[i]+1), /remo)
1544   - fxaddpar, header, 'TSCAL'+istr, 1.0, 'Set by MRD_SCALE'
1545   - fxaddpar, header, 'TZERO'+istr, 0.0, 'Set by MRD_SCALE'
1546   - endfor
1547   -
1548   - table = temporary(tabx)
1549   -
1550   - endif else begin
1551   - ; Now process images and random groups.
1552   -
1553   - sz = size(table[0])
1554   - if sz[sz[0]+1] ne 8 then begin
1555   - ; Not a structure so we just have an array of data.
1556   - if keyword_set(dscale) then begin
1557   - table = table*scales[0]+offsets[0]
1558   - endif else begin
1559   - table = table*float(scales[0]) + float(offsets[0])
1560   - endelse
1561   - fxaddpar, header, 'BSCALE', 1.0, 'Set by MRD_SCALE'
1562   - fxaddpar, header, 'BZERO', 0.0, 'Set by MRD_SCALE'
1563   -
1564   - endif else begin
1565   - ; Random groups. Get the number of parameters by looking
1566   - ; at the first element in the table.
1567   - nparam = n_elements(table[0].(0))
1568   - if keyword_set(dscale) then typ = 'dbl' else typ='flt'
1569   - s1 = typ+'arr('+string(nparam)+')'
1570   - ngr = n_elements(table)
1571   - sz = size(table[0].(1))
1572   - if sz[0] eq 0 then dims = [1] else dims=sz[1:sz[0]]
1573   - s2 = typ + 'arr('
1574   - for i=0, n_elements(dims)-1 do begin
1575   - if i ne 0 then s2 = s2+ ','
1576   - s2 = s2+string(dims[i])
1577   - endfor
1578   - s2 = s2+')'
1579   - tabx = mrd_struct(['params', 'array'],[s1,s2],ngr, silent=silent)
1580   -
1581   - for i=0, nparam-1 do begin
1582   - istr = strcompress(string(i+1),/remo)
1583   - fxaddpar, header, 'PSCAL'+istr, 1.0, 'Added by MRD_SCALE'
1584   - fxaddpar, header, 'PZERO'+istr, 0.0, 'Added by MRD_SCALE'
1585   - tabx.(0)[i] = table.(0)[i]*scales[i]+offsets[i]
1586   - endfor
1587   -
1588   - tabx.(1) = table.(1)*scales[nparam] + offsets[nparam]
1589   - fxaddpar, header, 'BSCALE', 1.0, 'Added by MRD_SCALE'
1590   - fxaddpar, header, 'BZERO', 0.0, 'Added by MRD_SCALE'
1591   - table = temporary(tabx)
1592   - endelse
1593   - endelse
1594   -
1595   -end
1596   -
1597   -; Read a variable length column into a pointer array.
1598   -pro mrd_varcolumn, vtype, array, heap, off, siz
1599   -
1600   - ; Guaranteed to have at least one non-zero length column
1601   - w = where(siz gt 0)
1602   - nw = n_elements(w)
1603   -
1604   - if vtype eq 'X' then siz = 1 + (siz-1)/8
1605   -
1606   - siz = siz[w]
1607   - off = off[w]
1608   -
1609   - unsigned = 0
1610   - if vtype eq '1' then begin
1611   - unsigned = 12
1612   - endif else if vtype eq '2' then begin
1613   - unsigned = 13
1614   - endif else if vtype eq '3' then begin
1615   - unsigned = 15;
1616   - endif
1617   - unsigned = mrd_unsigned_offset(unsigned)
1618   -
1619   -
1620   - for j=0, nw-1 do begin
1621   -
1622   - case vtype of
1623   -
1624   - 'L': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) )
1625   - 'X': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) )
1626   - 'B': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) )
1627   -
1628   - 'I': array[w[j]] = ptr_new( fix(heap, off[j], siz[j]) )
1629   - 'J': array[w[j]] = ptr_new( long(heap, off[j], siz[j]) )
1630   - 'K': array[w[j]] = ptr_new( long64(heap, off[j], siz[j]) )
1631   -
1632   - 'E': array[w[j]] = ptr_new( float(heap, off[j], siz[j]) )
1633   - 'D': array[w[j]] = ptr_new( double(heap, off[j], siz[j]) )
1634   -
1635   - 'C': array[w[j]] = ptr_new( complex(heap, off[j], siz[j]) )
1636   - 'M': array[w[j]] = ptr_new( dcomplex(heap, off[j], siz[j]) )
1637   -
1638   - '1': array[w[j]] = ptr_new( uint(heap, off[j], siz[j]) )
1639   - '2': array[w[j]] = ptr_new( ulong(heap, off[j], siz[j]) )
1640   - '3': array[w[j]] = ptr_new( ulong64(heap, off[j], siz[j]) )
1641   -
1642   - endcase
1643   -
1644   - ; Fix endianness.
1645   - if vtype ne 'B' and vtype ne 'X' and vtype ne 'L' then begin
1646   - swap_endian_inplace, *array[w[j]],/swap_if_little
1647   - endif
1648   -
1649   - ; Scale unsigneds.
1650   - if unsigned gt 0 then *array[w[j]] = *array[w[j]] - unsigned
1651   -
1652   - endfor
1653   -end
1654   -
1655   -; Read a variable length column into a fixed length array.
1656   -pro mrd_fixcolumn, vtype, array, heap, off, siz
1657   -
1658   - w = where(siz gt 0)
1659   - if w[0] eq -1 then return
1660   -
1661   - nw = n_elements(w)
1662   -
1663   -
1664   - if vtype eq 'X' then siz = 1 + (siz-1)/8
1665   -
1666   - siz = siz[w]
1667   - off = off[w]
1668   -
1669   - for j=0, nw-1 do begin
1670   - case vtype of
1671   - 'L': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j])
1672   - 'X': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j])
1673   - 'B': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j])
1674   -
1675   - 'I': array[0:siz[j]-1,w[j]] = fix(heap, off[j], siz[j])
1676   - 'J': array[0:siz[j]-1,w[j]] = long(heap, off[j], siz[j])
1677   - 'K': array[0:siz[j]-1,w[j]] = long64(heap, off[j], siz[j])
1678   -
1679   - 'E': begin ;Delay conversion until after byteswapping to avoid possible math overflow Feb 2005
1680   - temp = heap[off[j]: off[j] + 4*siz[j]-1 ]
1681   - byteorder, temp, /LSWAP, /SWAP_IF_LITTLE
1682   - array[0:siz[j]-1,w[j]] = float(temp,0,siz[j])
1683   - end
1684   - 'D': begin
1685   - temp = heap[off[j]: off[j] + 8*siz[j]-1 ]
1686   - byteorder, temp, /L64SWAP, /SWAP_IF_LITTLE
1687   - array[0:siz[j]-1,w[j]] = double(temp,0,siz[j])
1688   - end
1689   - 'C': array[0:siz[j]-1,w[j]] = complex(heap, off[j], siz[j])
1690   - 'M': array[0:siz[j]-1,w[j]] = dcomplex(heap, off[j], siz[j])
1691   -
1692   - 'A': array[w[j]] = string(byte(heap,off[j],siz[j]))
1693   -
1694   - '1': array[0:siz[j]-1,w[j]] = uint(heap, off[j], siz[j])
1695   - '2': array[0:siz[j]-1,w[j]] = ulong(heap, off[j], siz[j])
1696   - '3': array[0:siz[j]-1,w[j]] = ulong64(heap, off[j], siz[j])
1697   -
1698   - endcase
1699   -
1700   - endfor
1701   -
1702   - ; Fix endianness
1703   - if (vtype ne 'A') and (vtype ne 'B') and (vtype ne 'X') and (vtype ne 'L') and $
1704   - (vtype NE 'D') and (vtype NE 'E') then begin
1705   - swap_endian_inplace, array, /swap_if_little
1706   - endif
1707   -
1708   - ; Scale unsigned data
1709   - unsigned = 0
1710   - if vtype eq '1' then begin
1711   - unsigned = 12
1712   - endif else if vtype eq '2' then begin
1713   - unsigned = 13
1714   - endif else if vtype eq '3' then begin
1715   - unsigned = 15;
1716   - endif
1717   -
1718   - if unsigned gt 0 then begin
1719   - unsigned = mrd_unsigned_offset(unsigned)
1720   - endif
1721   -
1722   - if unsigned gt 0 then begin
1723   - for j=0, nw-1 do begin
1724   - array[0:siz[j]-1,w[j]] = array[0:siz[j]-1,w[j]] - unsigned
1725   - endfor
1726   - endif
1727   -
1728   -
1729   -end
1730   -
1731   -; Read the heap area to get the actual values of variable
1732   -; length arrays.
1733   -pro mrd_read_heap, unit, header, range, fnames, fvalues, vcls, vtpes, table, $
1734   - structyp, scaling, scales, offsets, status, silent=silent, $
1735   - columns=columns, rows = rows, pointer_var=pointer_var, fixed_var=fixed_var
1736   -
1737   - ;
1738   - ; Unit: FITS unit number.
1739   - ; header: FITS header.
1740   - ; fnames: Column names.
1741   - ; fvalues: Column values.
1742   - ; vcols: Column numbers of variable length columns.
1743   - ; vtypes: Actual types of variable length columns
1744   - ; table: Table of data from standard data area, on output
1745   - ; contains the variable length data.
1746   - ; structyp: Structure name.
1747   - ; scaling: Is there going to be scaling of the data?
1748   - ; status: Set to -1 if an error occurs.
1749   - ;
1750   - typstr = 'LXBIJKAEDCM123'
1751   - prefix = ['bytarr(', 'bytarr(', 'bytarr(', 'intarr(', $
1752   - 'lonarr(', 'lon64arr(', 'string(bytarr(', 'fltarr(', $
1753   - 'dblarr(', 'cmplxarr(', 'dblarr(2,', $
1754   - 'uintarr(', 'ulonarr(', 'ulon64arr(']
1755   -
1756   - status = 0
1757   -
1758   - ; Convert from a list of indicators of whether a column is variable
1759   - ; length to pointers to only the variable columns.
1760   -
1761   - vcols = where(vcls eq 1)
1762   - vtypes = vtpes[vcols]
1763   -
1764   - nv = n_elements(vcols)
1765   -
1766   - ; Find the beginning of the heap area.
1767   -
1768   - heapoff = long64(fxpar(header, 'THEAP'))
1769   - sz = fxpar(header, 'NAXIS1')*fxpar(header, 'NAXIS2')
1770   -
1771   - if heapoff ne 0 and heapoff lt sz then begin
1772   - print, 'MRDFITS: ERROR Heap begins within data area'
1773   - status = -1
1774   - return
1775   - endif
1776   -
1777   - ; Skip to beginning.
1778   - if (heapoff > sz) then begin
1779   - mrd_skip, unit, heapoff-sz
1780   - endif
1781   -
1782   - ; Get the size of the heap.
1783   - pc = long64(fxpar(header, 'PCOUNT'))
1784   - if heapoff eq 0 then heapoff = sz
1785   - hpsiz = pc - (heapoff-sz)
1786   -
1787   - if (hpsiz gt 0) then heap = bytarr(hpsiz)
1788   -
1789   -
1790   - ; Read in the heap
1791   - readu, unit, heap
1792   -
1793   - ; Skip to the end of the data area.
1794   - skipB = 2880 - (sz+pc) mod 2880
1795   - if skipB ne 2880 then begin
1796   - mrd_skip, unit, skipB
1797   - endif
1798   -
1799   - ; Find the maximum dimensions of the arrays.
1800   - ;
1801   - ; Note that the variable length column currently has fields which
1802   - ; are I*4 2-element arrays where the first element is the
1803   - ; length of the field on the current row and the second is the
1804   - ; offset into the heap.
1805   -
1806   - vdims = lonarr(nv)
1807   - for i=0, nv-1 do begin
1808   - col = vcols[i]
1809   - curr_col = table.(col)
1810   - vdims[i] = max(curr_col[0,*])
1811   - w = where(curr_col[0,*] ne vdims[i])
1812   - if w[0] ne -1 then begin
1813   - if n_elements(lencols) eq 0 then begin
1814   - lencols = [col]
1815   - endif else begin
1816   - lencols=[lencols,col]
1817   - endelse
1818   - endif
1819   -
1820   - if vtypes[i] eq 'X' then vdims[i]=(vdims[i]+7)/8
1821   - ind = strpos(typstr, vtypes[i])
1822   -
1823   - ; Note in the following that we ensure that the array is
1824   - ; at least one element long.
1825   -
1826   - fvalues[col] = prefix[ind] + string((vdims[i] > 1)) + ')'
1827   - if vtypes[i] eq 'A' then fvalues[col] = fvalues[col] + ')'
1828   -
1829   - endfor
1830   -
1831   - nfld = n_elements(fnames)
1832   -
1833   - ; Get rid of columns which have no actual data.
1834   - w= intarr(nfld)
1835   - w[*] = 1
1836   - corres = indgen(nfld)
1837   -
1838   -
1839   - ; Should we get rid of empty columns?
1840   - delete = 1
1841   - if keyword_set(pointer_var) then delete = pointer_var eq 1
1842   -
1843   - if delete then begin
1844   -
1845   - ww = where(vdims eq 0)
1846   - if ww[0] ne -1 then begin
1847   - w[vcols[ww]] = 0
1848   - if not keyword_set(silent) then begin
1849   - print, 'MRDFITS: ', strcompress(string(n_elements(ww))), $
1850   - ' unused variable length columns deleted'
1851   - endif
1852   - endif
1853   -
1854   - ; Check if all columns have been deleted...
1855   - wx = where(w gt 0)
1856   - if (wx[0] eq -1) then begin
1857   - if not keyword_set(silent) then begin
1858   - print, 'MRDFITS: All columns have been deleted'
1859   - endif
1860   - table = 0
1861   - return
1862   - endif
1863   -
1864   -
1865   - ; Get rid of unused columns.
1866   - corres = corres[wx]
1867   - fnames = fnames[wx]
1868   - fvalues = fvalues[wx]
1869   - scales = scales[wx]
1870   - offsets = offsets[wx]
1871   -
1872   - wx = where(vdims gt 0)
1873   -
1874   - if (wx[0] eq -1) then begin
1875   - vcols=[-9999]
1876   - x=temporary(vtypes)
1877   - x=temporary(vdims)
1878   - endif else begin
1879   - vcols = vcols[wx]
1880   - vtypes = vtypes[wx]
1881   - vdims = vdims[wx]
1882   - endelse
1883   - endif
1884   -
1885   - if not keyword_set(pointer_var) then begin
1886   - ; Now add columns for lengths of truly variable length records.
1887   - if n_elements(lencols) gt 0 then begin
1888   - if not keyword_set(silent) then begin
1889   - print, 'MRDFITS: ', strcompress(string(n_elements(lencols))), $
1890   - ' length column[s] added'
1891   - endif
1892   -
1893   -
1894   - for i=0, n_elements(lencols)-1 do begin
1895   - col = lencols[i]
1896   - w = where(col eq corres)
1897   - ww = where(col eq vcols)
1898   - w = w[0]
1899   - ww = ww[0]
1900   - fvstr = '0L' ; <-- Originally, '0l'; breaks under the virtual machine!
1901   - fnstr = 'L'+strcompress(string(col),/remo)+'_'+fnames[w]
1902   - nf = n_elements(fnames)
1903   -
1904   - ; Note that lencols and col refer to the index of the
1905   - ; column before we started adding in the length
1906   - ; columns.
1907   -
1908   - if w eq nf-1 then begin
1909   - ; Subtract -1 for the length columns so 0 -> -1 and
1910   - ; we can distinguish this column.
1911   -
1912   - corres = [corres, -col-1 ]
1913   - fnames = [fnames, fnstr ]
1914   - fvalues = [fvalues, fvstr ]
1915   - scales = [scales, 1.0d0 ]
1916   - offsets = [offsets, 0.0d0 ]
1917   -
1918   - endif else begin
1919   -
1920   - corres = [corres[0:w],-col-1,corres[w+1:nf-1] ]
1921   - fnames = [fnames[0:w],fnstr,fnames[w+1:nf-1] ]
1922   - fvalues = [fvalues[0:w],fvstr,fvalues[w+1:nf-1] ]
1923   - scales = [scales[0:w], 1.0d0, scales[w+1:nf-1] ]
1924   - offsets = [offsets[0:w],0.0d0, offsets[w+1:nf-1] ]
1925   - endelse
1926   - endfor
1927   - endif
1928   -
1929   - endif else begin
1930   -
1931   - ; We'll just read data into pointer arrays.
1932   - for i=0,n_elements(lencols)-1 do begin
1933   - col = lencols[i]
1934   - if vtpes[col] eq 'A' then begin
1935   - fvalues[col] = '" "'
1936   - endif else begin
1937   - fvalues[col] = 'ptr_new()'
1938   - endelse
1939   - endfor
1940   -
1941   - endelse
1942   -
1943   -
1944   -
1945   - ; Generate a new table with the appropriate structure definitions
1946   - if not scaling and not keyword_set(columns) then begin
1947   - tablex = mrd_struct(fnames, fvalues, n_elements(table), structyp=structyp, $
1948   - silent=silent)
1949   - endif else begin
1950   - tablex = mrd_struct(fnames, fvalues, n_elements(table), silent=silent)
1951   - endelse
1952   -
1953   -
1954   - if N_elements(rows) EQ 0 then nrow = range[1]-range[0]+1 $
1955   - else nrow = N_elements(rows)
1956   -
1957   - ; I loops over the new table columns, col loops over the old table.
1958   - ; When col is negative, it is a length column.
1959   - for i=0, n_elements(fnames)-1 do begin
1960   -
1961   - col = corres[i]
1962   -
1963   - if col ge 0 then begin
1964   -
1965   - w = where(vcols eq col)
1966   -
1967   - ; First handle the case of a column that is not
1968   - ; variable length -- just copy the column.
1969   -
1970   - if w[0] eq -1 then begin
1971   -
1972   - tablex.(i) = table.(col)
1973   -
1974   - endif else begin
1975   -
1976   - vc = w[0]
1977   - ; Now handle the variable length columns
1978   -
1979   - ; If only one row in table, then
1980   - ; IDL will return curr_col as one-dimensional.
1981   - ; Since this is a variable length pointer column we
1982   - ; know that the dimension of the column is 2.
1983   - curr_col = table.(col)
1984   -
1985   - if (nrow eq 1) then curr_col = reform(curr_col,2,1)
1986   - siz = curr_col[0,*]
1987   - off = curr_col[1,*]
1988   -
1989   - ; Now process each type.
1990   - curr_colx = tablex.(i)
1991   - sz = size(curr_colx)
1992   - if (sz[0] lt 2) then begin
1993   - curr_colx = reform(curr_colx, 1, n_elements(curr_colx), /overwrite)
1994   - endif
1995   -
1996   -
1997   - ; As above we have to worry about IDL truncating
1998   - ; dimensions. This can happen if either
1999   - ; nrow=1 or the max dimension of the column is 1.
2000   -
2001   -
2002   - sz = size(tablex.(i))
2003   -
2004   - nel = sz[sz[0]+2]
2005   - if nrow eq 1 and nel eq 1 then begin
2006   - curr_colx = make_array(1,1,value=curr_colx)
2007   - endif else if nrow eq 1 then begin
2008   - curr_colx = reform(curr_colx,[nel, 1], /overwrite)
2009   - endif else if nel eq 1 then begin
2010   - curr_colx = reform(curr_colx,[1, nrow], /overwrite)
2011   - endif
2012   -
2013   - vtype = vtypes[vc]
2014   - varying = 0
2015   - if n_elements(lencols) gt 0 then begin
2016   - varying = where(lencols eq col)
2017   - if varying[0] eq -1 then varying=0 else varying=1
2018   - endif
2019   -
2020   - if varying and keyword_set(pointer_var) and vtype ne 'A' then begin
2021   - mrd_varcolumn, vtype, curr_colx, heap, off, siz
2022   - endif else begin
2023   - mrd_fixcolumn, vtype, curr_colx, heap, off, siz
2024   - endelse
2025   -
2026   -
2027   -
2028   - if nel eq 1 and nrow eq 1 then begin
2029   - curr_colx = curr_colx[0]
2030   - endif else if nrow eq 1 then begin
2031   - curr_colx = reform(curr_colx, nel, /overwrite)
2032   - endif else if nel eq 1 then begin
2033   - curr_colx = reform(curr_colx, nrow, /overwrite)
2034   - endif
2035   -
2036   - sz = size(curr_colx)
2037   - if sz[1] eq 1 then begin
2038   - sz_tablex = size(tablex.(i))
2039   - sdimen = sz_tablex[1:sz_tablex[0]]
2040   - tablex.(i) = reform(curr_colx,sdimen)
2041   - endif else begin
2042   - tablex.(i) = curr_colx
2043   - endelse
2044   -
2045   - endelse
2046   -
2047   - endif else begin
2048   - ; Now handle the added columns which hold the lengths
2049   - ; of the variable length columns.
2050   -
2051   - ncol = -col - 1 ; Remember we subtracted an extra one.
2052   - xx = table.(ncol)
2053   - tablex.(i) = reform(xx[0,*])
2054   - endelse
2055   - endfor
2056   -
2057   - ; Finally get rid of the initial table and return the table with the
2058   - ; variable arrays read in.
2059   - ;
2060   - table = temporary(tablex)
2061   - return
2062   -end
2063   -
2064   -; Read in the binary table information.
2065   -pro mrd_read_table, unit, range, rsize, structyp, nrows, nfld, typarr, table, rows = rows
2066   -
2067   - ;
2068   - ;
2069   - ; Unit Unit to read data from.
2070   - ; Range Desired range
2071   - ; Rsize Size of row.
2072   - ; structyp Structure type.
2073   - ; Nfld Number of fields in structure.
2074   - ; Typarr Field types
2075   - ; Table Table to read information into.
2076   - ;
2077   -
2078   - if range[0] gt 0 then mrd_skip, unit, rsize*range[0]
2079   - readu,unit, table
2080   - if N_elements(rows) GT 0 then table = table[rows- range[0]]
2081   -
2082   - ; Move to the beginning of the heap -- we may have only read some rows of
2083   - ; the data.
2084   - if range[1] lt nrows-1 then begin
2085   - skip_dist = (nrows-range[1]-1)*rsize
2086   - mrd_skip, unit, skip_dist
2087   - endif
2088   -
2089   -
2090   -
2091   - ; If necessary then convert to native format.
2092   - if byte(1L, 0,1) EQ 1 then begin
2093   -
2094   - for i=0, nfld-1 do begin
2095   -
2096   - typ = typarr[i]
2097   - if typ eq 'B' or typ eq 'A' or typ eq 'X' or typ eq 'L' $
2098   - then goto, nxtfld
2099   - fld = table.(i)
2100   - if typ eq 'I' then byteorder, fld, /htons
2101   - if typ eq 'J' or typ eq 'P' then byteorder, fld, /htonl
2102   - if typ eq 'K' then byteorder, fld, /l64swap
2103   - if typ eq 'E' or typarr[i] eq 'C' then $
2104   - byteorder, fld, /LSWAP
2105   -
2106   - if typ eq 'D' or typarr[i] eq 'M' then byteorder, fld, /L64SWAP
2107   -
2108   - if n_elements(fld) gt 1 then begin
2109   -
2110   - table.(i) = fld
2111   - endif else begin
2112   - table.(i) = fld[0]
2113   - endelse
2114   - nxtfld:
2115   - endfor
2116   - endif
2117   -
2118   - ; Handle unsigned fields.
2119   - for i=0, nfld-1 do begin
2120   -
2121   -
2122   - type = mrd_unsignedtype(table.(i))
2123   -
2124   - if type gt 0 then begin
2125   - table.(i) = table.(i) - mrd_unsigned_offset(type)
2126   - endif
2127   -
2128   -
2129   - endfor
2130   -
2131   -end
2132   -
2133   -
2134   -; Check the values of TDIM keywords to see that they have valid
2135   -; dimensionalities. If the TDIM keyword is not present or valid
2136   -; then the a one-dimensional array with a size given in the TFORM
2137   -; keyword is used.
2138   -
2139   -pro mrd_tdim, header, index, flen, arrstr, no_tdim=no_tdim
2140   -
2141   - ; HEADER Current header array.
2142   - ; Index Index of current parameter
2143   - ; flen Len given in TFORM keyword
2144   - ; arrstr String returned to be included within paren's in definition.
2145   - ; no_tdim Disable TDIM processing
2146   -
2147   - arrstr = strcompress(string(flen),/remo)
2148   -
2149   - if keyword_set(no_tdim) then return
2150   -
2151   - tdstr = fxpar(header, 'TDIM'+strcompress(string(index),/remo))
2152   - if tdstr eq '' then return
2153   -
2154   - ;
2155   - ; Parse the string. It should be of the form '(n1,n2,...nx)' where
2156   - ; all of the n's are positive integers and the product equals flen.
2157   - ;
2158   - tdstr = strcompress(tdstr,/remo)
2159   - len = strlen(tdstr)
2160   - if strmid(tdstr,0,1) ne '(' and strmid(tdstr,len-1,1) ne ')' or len lt 3 then begin
2161   - print, 'MRDFITS: Error: invalid TDIM for column', index
2162   - return
2163   - endif
2164   -
2165   - ; Get rid of parens.
2166   - tdstr = strmid(tdstr,1,len-2)
2167   - len = len-2
2168   -
2169   - nind = 0
2170   - cnum = 0
2171   -
2172   - for nchr=0, len-1 do begin
2173   - c = strmid(tdstr,nchr, 1)
2174   -
2175   - if c ge '0' and c le '9' then begin
2176   - cnum = 10*cnum + long(c)
2177   -
2178   - endif else if c eq ',' then begin
2179   -
2180   - if cnum le 0 then begin
2181   - print,'MRDFITS: Error: invalid TDIM for column', index
2182   - return
2183   - endif
2184   -
2185   - if n_elements(numbs) eq 0 then $
2186   - numbs = cnum $
2187   - else numbs = [numbs,cnum]
2188   -
2189   - cnum = 0
2190   -
2191   - endif else begin
2192   -
2193   - print,'MRDFITS: Error: invalid TDIM for column', index
2194   - return
2195   -
2196   - endelse
2197   -
2198   - endfor
2199   -
2200   - ; Handle the last number.
2201   - if cnum le 0 then begin
2202   - print,'MRDFITS: Error: invalid TDIM for column', index
2203   - return
2204   - endif
2205   -
2206   - if n_elements(numbs) eq 0 then numbs = cnum else numbs = [numbs,cnum]
2207   -
2208   - prod = 1
2209   -
2210   - for i=0, n_elements(numbs)-1 do prod = prod*numbs[i]
2211   -
2212   - if prod ne flen then begin
2213   - print,'MRDFITS: Error: TDIM/TFORM dimension mismatch'
2214   - return
2215   - endif
2216   -
2217   - arrstr = tdstr
2218   -end
2219   -
2220   -; Define a structure to hold a FITS binary table.
2221   -pro mrd_table, header, structyp, use_colnum, $
2222   - range, rsize, table, nrows, nfld, typarr, fnames, fvalues, $
2223   - vcls, vtpes, scales, offsets, scaling, status, rows = rows, $
2224   - silent=silent, columns=columns, no_tdim=no_tdim, $
2225   - alias=alias, unsigned=unsigned
2226   -
2227   - ;
2228   - ; Header FITS header for table.
2229   - ; Structyp IDL structure type to be used for
2230   - ; structure.
2231   - ; N_call Number of times this routine has been called.
2232   - ; Table Structure to be defined.
2233   - ; Status Return status.
2234   - ; No_tdim Disable TDIM processing.
2235   -
2236   - table = 0
2237   -
2238   - types = ['L', 'X', 'B', 'I', 'J', 'K', 'A', 'E', 'D', 'C', 'M', 'P']
2239   - arrstr = ['bytarr(', 'bytarr(', 'bytarr(', 'intarr(', 'lonarr(', 'lon64arr(', $
2240   - 'string(replicate(32b,', 'fltarr(', 'dblarr(', 'complexarr(', $
2241   - 'dcomplexarr(', 'lonarr(2*']
2242   - bitpix = [ 0, 0, 0, 16, 32, 64, 0, 0, 0, 0, 0, 0]
2243   -
2244   - sclstr = ["'T'", '0B', '0B', '0', '0L', '0LL', '" "', '0.', '0.d0', 'complex(0.,0.)', $
2245   - 'dcomplex(0.d0,0.d0)', 'lonarr(2)']
2246   -
2247   - unsarr = ['', '', '', 'uintarr(', 'ulonarr(', 'ulon64arr('];
2248   - unsscl = ['', '', '', '0U', '0UL', '0ULL']
2249   -
2250   -
2251   - status = 0
2252   -
2253   -; NEW WAY: E.S.S.
2254   -
2255   - ;; get info from header. Using vectors is much faster
2256   - ;; when there are many columns
2257   -
2258   - mrd_fxpar, header, xten, nfld, nrow, rsize, fnames, fforms, scales, offsets
2259   - nnames = n_elements(fnames)
2260   -
2261   - ;; nrow will change later
2262   - nrows = nrow
2263   -
2264   - ;; Use scale=1 if not found
2265   - if nnames GT 0 then begin
2266   - wsc=where(scales EQ 0.0d,nwsc)
2267   - IF nwsc NE 0 THEN scales[wsc] = 1.0d
2268   - endif
2269   -
2270   - xten = strtrim(xten,2)
2271   - if xten ne 'BINTABLE' and xten ne 'A3DTABLE' then begin
2272   - print, 'MRDFITS: ERROR - Header is not from binary table.'
2273   - nfld = 0 & status = -1
2274   - return
2275   - endif
2276   -
2277   - if range[0] ge 0 then begin
2278   - range[0] = range[0] < (nrow-1)
2279   - range[1] = range[1] < (nrow-1)
2280   - endif else begin
2281   - range[0] = 0
2282   - range[1] = nrow - 1
2283   - endelse
2284   -
2285   - nrow = range[1] - range[0] + 1
2286   - if nrow le 0 then begin
2287   - if not keyword_set(silent) then begin
2288   - print, 'MRDFITS: Binary table. ', $
2289   - strcompress(string(nfld)), ' columns, no rows.'
2290   - endif
2291   - return
2292   - endif
2293   -
2294   - if N_elements(rows) EQ 0 then nrowp = nrow else begin
2295   - bad = where((rows LT range[0]) or (rows GT range[1]), Nbad)
2296   - if Nbad GT 0 then begin
2297   - print,'MRDFITS: Row numbers must be between 0 and ' + $
2298   - strtrim(nrow-1,2)
2299   - status = -1
2300   - return
2301   - endif
2302   - nrowp = N_elements(rows)
2303   - endelse
2304   -; rsize = fxpar(header, 'NAXIS1')
2305   -
2306   - ;
2307   - ; Loop over the columns
2308   -
2309   - typarr = strarr(nfld)
2310   -; fnames = strarr(nfld)
2311   -
2312   - fvalues = strarr(nfld)
2313   - dimfld = strarr(nfld)
2314   -; scales = dblarr(nfld)
2315   -; offsets = dblarr(nfld)
2316   -
2317   - vcls = intarr(nfld)
2318   - vtpes = strarr(nfld)
2319   -
2320   - fnames2 = strarr(nfld)
2321   -
2322   - for i=0, nfld-1 do begin
2323   -
2324   - istr = strcompress(string(i+1), /remo)
2325   -
2326   - fname = fnames[i]
2327   -
2328   - ;; check for a name conflict
2329   - fname = mrd_dofn(fname, i+1, use_colnum, alias=alias)
2330   -
2331   - ;; check for a name conflict
2332   - fname = mrd_chkfn(fname, fnames2, i)
2333   -
2334   - ;; copy in the valid name
2335   - fnames[i] = fname
2336   - ;; for checking conflicts
2337   - fnames2[i] = fname
2338   -
2339   -; fname = fxpar(header, 'TTYPE' + istr)
2340   -; fform = strtrim( fxpar(header, 'TFORM' + istr),2)
2341   -
2342   -; scales[i] = fxpar(header, 'TSCAL'+istr)
2343   -; if scales[i] eq 0.d0 then scales[i] = 1.d0
2344   -
2345   -; offsets[i] = fxpar(header, 'TZERO'+istr)
2346   -
2347   -; fname = mrd_dofn(fname,i+1, use_colnum, alias=alias)
2348   -; fname = mrd_chkfn(fname, fnames, i)
2349   -
2350   -; fnames[i] = fname
2351   -
2352   - fform = fforms[i]
2353   -
2354   - mrd_doff, fform, dim, ftype
2355   -
2356   - ; Treat arrays of length 1 as scalars.
2357   - if dim eq 1 then begin
2358   - dim = 0
2359   - endif else if dim EQ -1 then begin
2360   - dimfld[i] = -1
2361   - endif else begin
2362   - mrd_tdim, header, i+1, dim, str, no_tdim=no_tdim
2363   - dimfld[i] = str
2364   - endelse
2365   -
2366   - typarr[i] = ftype
2367   -
2368   -
2369   - ; Find the number of bytes in a bit array.
2370   -
2371   - if ftype eq 'X' and dim gt 0 then begin
2372   - dim = (dim+7)/8
2373   - dimfld[i] = strtrim(string(dim),2)
2374   - endif
2375   -
2376   - ; Add in the structure label.
2377   - ;
2378   -
2379   - ; Handle variable length columns.
2380   - if ftype eq 'P' then begin
2381   -
2382   - if dim ne 0 and dim ne 1 then begin
2383   - print, 'MRDFITS: Invalid dimension for variable array column '+string(i+1)
2384   - status = -1
2385   - return
2386   - endif
2387   -
2388   - ppos = strpos(fform, 'P')
2389   - vf = strmid(fform, ppos+1, 1);
2390   - if strpos('LXBIJKAEDCM', vf) eq -1 then begin
2391   - print, 'MRDFITS: Invalid type for variable array column '+string(i+1)
2392   - status = -1
2393   - return
2394   - endif
2395   -
2396   - vcls[i] = 1
2397   -
2398   -; xscale =fxpar(header,'TSCAL'+istr,count=cnt)
2399   -; if cnt eq 0 then xscale = 1
2400   -
2401   -; xunsigned = mrd_chkunsigned(bitpix[ppos], xscale, $
2402   -; fxpar(header, 'TZERO'+istr), $
2403   -; unsigned=unsigned)
2404   -
2405   - xunsigned = mrd_chkunsigned(bitpix[ppos], scales[i], $
2406   - offsets[i], $
2407   - unsigned=unsigned)
2408   -
2409   - if (xunsigned) then begin
2410   -
2411   - if vf eq 'I' then vf = '1' $
2412   - else if vf eq 'J' then vf = '2' $
2413   - else if vf eq 'K' then vf = '3'
2414   -
2415   - endif
2416   -
2417   - vtpes[i] = vf
2418   - dim = 0
2419   -
2420   - endif
2421   -
2422   -
2423   - for j=0, n_elements(types) - 1 do begin
2424   -
2425   - if ftype eq types[j] then begin
2426   -
2427   -; xscale = fxpar(header, 'TSCAL'+istr, count=cnt)
2428   -; if cnt eq 0 then xscale = 1
2429   -
2430   -; xunsigned = mrd_chkunsigned(bitpix[j], xscale, $
2431   -; fxpar(header, 'TZERO'+istr), $
2432   -; unsigned=unsigned)
2433   -
2434   - xunsigned = mrd_chkunsigned(bitpix[j], scales[i], $
2435   - offsets[i], $
2436   - unsigned=unsigned)
2437   -
2438   - if xunsigned then begin
2439   - fxaddpar, header, 'TZERO'+istr, 0, 'Modified by MRDFITS V'+mrd_version()
2440   - offsets[i] = 0 ;; C. Markwardt Aug 2007 - reset to zero so offset is not applied twice'
2441   - endif
2442   -
2443   - if dim eq 0 then begin
2444   -
2445   - if xunsigned then begin
2446   - fvalues[i] = unsscl[j]
2447   - endif else begin
2448   - fvalues[i] = sclstr[j]
2449   - endelse
2450   -
2451   - endif else begin
2452   -
2453   - if xunsigned then begin
2454   - line = unsarr[j]
2455   - endif else begin
2456   - line = arrstr[j]
2457   - endelse
2458   -
2459   - line = line + dimfld[i] + ')'
2460   - if ftype eq 'A' then line = line + ')'
2461   - fvalues[i] = line
2462   -
2463   - endelse
2464   -
2465   - goto, next_col
2466   -
2467   - endif
2468   -
2469   - endfor
2470   -
2471   - print, 'MRDFITS: Invalid format code:',ftype, ' for column ', i+1
2472   - status = -1
2473   - return
2474   - next_col:
2475   - endfor
2476   -
2477   - ; Check if there are any variable length columns. If not then
2478   - ; undefine vcls and vtpes
2479   - w = where(vcls eq 1)
2480   - if w[0] eq -1 then begin
2481   - dummy = temporary(vcls)
2482   - dummy = temporary(vtpes)
2483   - dummy = 0
2484   - endif
2485   -
2486   - if scaling then begin
2487   - w = where(scales ne 1.0d0 or offsets ne 0.0d0)
2488   - if w[0] eq -1 then scaling = 0
2489   - endif
2490   -
2491   - zero = where(long(dimfld) LT 0L, N_zero)
2492   - if N_zero GT 0 then begin
2493   -
2494   - if N_zero Eq nfld then begin
2495   - print,'MRDFITS: Error - All fields have zero length'
2496   - return
2497   - endif
2498   -
2499   - for i=0, N_zero-1 do begin
2500   - print,'MRDFITS: Table column ' + fnames[zero[i]] + ' has zero length'
2501   - endfor
2502   -
2503   - nfld = nfld - N_zero
2504   - good = where(dimfld GE 0)
2505   - fnames = fnames[good]
2506   - fvalues = fvalues[good]
2507   - typarr = typarr[good] ;Added 2005-1-6 (A.Csillaghy)
2508   -
2509   - endif
2510   -
2511   - if n_elements(vcls) eq 0 and (not scaling) and not keyword_set(columns) then begin
2512   -
2513   - table = mrd_struct(fnames, fvalues, nrow, structyp=structyp, silent=silent )
2514   -
2515   - endif else begin
2516   -
2517   - table = mrd_struct(fnames, fvalues, nrow, silent=silent )
2518   -
2519   - endelse
2520   -
2521   - if not keyword_set(silent) then begin
2522   - print, 'MRDFITS: Binary table. ',strcompress(string(nfld)), ' columns by ', $
2523   - strcompress(string(nrowp)), ' rows.'
2524   - if n_elements(vcls) gt 0 then begin
2525   - print, 'MRDFITS: Uses variable length arrays'
2526   - endif
2527   - endif
2528   -
2529   - status = 0
2530   - return
2531   -
2532   -end
2533   -
2534   -function mrdfits, file, extension, header, $
2535   - structyp = structyp, $
2536   - use_colnum = use_colnum, $
2537   - range = range, $
2538   - dscale = dscale, fscale=fscale, $
2539   - silent = silent, $
2540   - columns = columns, $
2541   - no_tdim = no_tdim, $
2542   - error_action = error_action, $
2543   - compress=compress, $
2544   - alias=alias, $
2545   - rows = rows, $
2546   - unsigned=unsigned, $
2547   - version=version, $
2548   - pointer_var=pointer_var, $
2549   - fixed_var=fixed_var, $
2550   - status=status, extnum = extnum
2551   -
2552   - compile_opt idl2
2553   - ; Let user know version if MRDFITS being used.
2554   - if keyword_set(version) then begin
2555   - print,'MRDFITS: Version '+mrd_version()+' Dec 12, 2007'
2556   - endif
2557   -
2558   - ;
2559   - ; Can't use keyword_set since default is 2, not 0.
2560   -
2561   - if n_elements(error_action) eq 0 then begin
2562   - error_action = 2
2563   - endif
2564   -
2565   - on_error, error_action
2566   -
2567   -
2568   -
2569   - ; Check positional arguments.
2570   -
2571   - if n_params() le 0 or n_params() gt 3 then begin
2572   - if keyword_set(version) then return, 0
2573   - print, 'MRDFITS: Usage'
2574   - print, ' a=mrdfits(file/unit, [exten_no/exten_name, header], /version $'
2575   - print, ' /fscale, /dscale, /unsigned, /use_colnum, /silent $'
2576   - print, ' range=, rows= , structyp=, columns=, $'
2577   - print, ' /pointer_var, /fixed_var, error_action=, status= )'
2578   - return, 0
2579   - endif
2580   -
2581   - if n_params() eq 1 then extension = 0
2582   -
2583   - ; Check optional arguments.
2584   - ;
2585   - ; *** Structure name ***
2586   -
2587   - if keyword_set(structyp) then begin
2588   - sz = size(structyp)
2589   - if sz[0] ne 0 then begin
2590   - ; Use first element of array
2591   - structyp = structyp[0]
2592   - sz = size(structyp[0])
2593   - endif
2594   -
2595   - if sz[1] ne 7 then begin
2596   - print, 'MRDFITS: stucture type must be a string'
2597   - return, 0
2598   - endif
2599   - endif
2600   -
2601   - ; *** Use column numbers not names?
2602   - if not keyword_set(use_colnum) then use_colnum = 0
2603   -
2604   - ; *** Get only a part of the FITS file.
2605   - if N_elements(rows) GT 0 then begin
2606   - range1 = min(rows,max=range2)
2607   - range = [range1,range2]
2608   - endif
2609   - if keyword_set(range) then begin
2610   - if n_elements(range) eq 2 then arange = range $
2611   - else if n_elements(range) eq 1 then arange = [0,range[0]-1] $
2612   - else if n_elements(range) gt 2 then arange = range[0:1] $
2613   - else if n_elements(range) eq 0 then arange = [-1,-1]
2614   -
2615   - endif else begin
2616   - arange = [-1,-1]
2617   - endelse
2618   -
2619   - arange = long(arange)
2620   -
2621   - ; Open the file and position to the appropriate extension then read
2622   - ; the header.
2623   -
2624   - if (N_elements(file) GT 1 ) then begin
2625   - print, 'MRDFITS: Vector input not supported'
2626   - return, 0
2627   - endif
2628   -
2629   - inputUnit = 0
2630   -
2631   - dtype = size(file,/type)
2632   - if dtype gt 0 and dtype lt 4 then begin ;File unit number specified
2633   -
2634   - inputUnit = 1
2635   - unit = file
2636   -
2637   - if fxmove(unit,extension) lt 0 then begin
2638   - return, -1
2639   - endif
2640   -
2641   - endif else begin ;File name specified
2642   - unit = fxposit(file, extension, compress=compress, $
2643   - /readonly,extnum=extnum, errmsg= errmsg)
2644   -
2645   - if unit lt 0 then begin
2646   - message, 'File access error',/CON
2647   - if errmsg NE '' then message,errmsg,/CON
2648   - status = -1
2649   - return, 0
2650   - endif
2651   - endelse
2652   -
2653   - if eof(unit) then begin
2654   - print,'MRDFITS: Extension past EOF'
2655   - if inputUnit eq 0 then free_lun,unit
2656   - status = -2
2657   - return, 0
2658   - endif
2659   -
2660   - mrd_hread, unit, header, status, SILENT = silent
2661   -
2662   - if status lt 0 then begin
2663   - print, 'MRDFITS: Unable to read header for extension'
2664   - if inputUnit eq 0 then free_lun,unit
2665   - return, 0
2666   - endif
2667   -
2668   - ; If this is primary array then XTENSION will have value
2669   - ; 0 which will be converted by strtrim to '0'
2670   -
2671   - xten = strtrim( fxpar(header,'XTENSION'), 2)
2672   - if xten eq '0' or xten eq 'IMAGE' then type = 0 $
2673   - else if xten eq 'TABLE' then type = 1 $
2674   - else if xten eq 'BINTABLE' or xten eq 'A3DTABLE' then type = 2 $
2675   - else begin
2676   - message, 'Unable to process extension type:', xten,/CON
2677   - if inputUnit eq 0 then free_lun,unit
2678   - status = -1
2679   - return, 0
2680   - endelse
2681   -
2682   - scaling = keyword_set(fscale) or keyword_set(dscale)
2683   -
2684   - if type eq 0 then begin
2685   -
2686   - ;*** Images/arrays
2687   -
2688   - mrd_image, header, arange, maxd, rsize, table, scales, offsets, $
2689   - scaling, status, silent=silent, unsigned=unsigned, $
2690   - rows= rows
2691   - if status ge 0 and rsize gt 0 then begin
2692   - mrd_read_image, unit, arange, maxd, rsize, table, rows = rows,$
2693   - status=status
2694   - endif
2695   - size = rsize
2696   - endif else if type eq 1 then begin
2697   -
2698   - ;*** ASCII tables.
2699   -
2700   - mrd_ascii, header, structyp, use_colnum, $
2701   - arange, table, nbytes, nrows, nfld, rows=rows, $
2702   - typarr, posarr, lenarr, nullarr, fnames, fvalues, $
2703   - scales, offsets, scaling, status, silent=silent, $
2704   - columns=columns, alias=alias
2705   - size = nbytes*nrows
2706   -
2707   - if status ge 0 and size gt 0 then begin
2708   -
2709   - ;*** Read data.
2710   - mrd_read_ascii, unit, arange, nbytes, nrows, $
2711   - nfld, typarr, posarr, lenarr, nullarr, table, rows= rows
2712   -
2713   - ;*** Extract desired columns.
2714   - if status ge 0 and keyword_set(columns) then $
2715   - mrd_columns, table, columns, fnames, fvalues, vcls, vtps, $
2716   - scales, offsets, scaling, structyp=structyp, silent=silent
2717   - endif
2718   -
2719   - endif else begin
2720   -
2721   - ; *** Binary tables.
2722   -
2723   - mrd_table, header, structyp, use_colnum, $
2724   - arange, rsize, table, nrows, nfld, typarr, $
2725   - fnames, fvalues, vcls, vtpes, scales, offsets, scaling, status, $
2726   - silent=silent, columns=columns, no_tdim=no_tdim, $
2727   - alias=alias, unsigned=unsigned, rows = rows
2728   -
2729   - size = nfld*(arange[1] - arange[0] + 1)
2730   - if status ge 0 and size gt 0 then begin
2731   -
2732   - ;*** Read data.
2733   - mrd_read_table, unit, arange, rsize, rows = rows, $
2734   - structyp, nrows, nfld, typarr, table
2735   -
2736   - if status ge 0 and keyword_set(columns) then begin
2737   -
2738   - ;*** Extract desired columns.
2739   - mrd_columns, table, columns, fnames, fvalues, $
2740   - vcls, vtpes, scales, offsets, scaling, structyp=structyp, $
2741   - silent=silent
2742   -
2743   - endif
2744   -
2745   -
2746   - if status ge 0 and n_elements(vcls) gt 0 then begin
2747   -
2748   - ;*** Get variable length columns
2749   - mrd_read_heap, unit, header, arange, fnames, fvalues, $
2750   - vcls, vtpes, table, structyp, scaling, scales, offsets, status, $
2751   - silent=silent, pointer_var=pointer_var, fixed_var=fixed_var, rows= rows
2752   -
2753   - endif else begin
2754   -
2755   - ; Skip remainder of last data block
2756   - sz = long64(fxpar(header, 'NAXIS1'))* $
2757   - long64(fxpar(header,'NAXIS2')) + $
2758   - long64(fxpar(header, 'PCOUNT'))
2759   - skipB = 2880 - sz mod 2880
2760   - if (skipB ne 2880) then mrd_skip, unit, skipB
2761   - endelse
2762   -
2763   - endif
2764   -
2765   - endelse
2766   -
2767   -
2768   - ; Don't tie up a unit number that we allocated in this routine.
2769   - if unit gt 0 and inputUnit eq 0 then begin
2770   - free_lun, unit
2771   - endif
2772   -
2773   - if status ge 0 and scaling and size gt 0 then begin
2774   - w = where(scales ne 1.d0 or offsets ne 0.0d0)
2775   -
2776   - ;*** Apply scalings.
2777   - if w[0] ne -1 then mrd_scale, type, scales, offsets, table, header, $
2778   - fnames, fvalues, 1+arange[1]-arange[0], structyp=structyp, $
2779   - dscale=dscale, silent=silent
2780   - endif
2781   -
2782   - ; All done. Check the status to see if we ran into problems on the way.
2783   -
2784   - if status ge 0 then return, table else return,0
2785   -
2786   -end