;+
; NAME:
;   ANGUNITVEC
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Convert longitude and (co)latitude (RA/Dec) to unit vector
;
; MAJOR TOPICS:
;   Geometry
;
; CALLING SEQUENCE:
;   U = ANGUNITVEC(LON, LAT, [/DEC])
;
; DESCRIPTION:
;
;   The function ANGUNITVEC converts spherical polar angles into a
;   unit vector.
;
;   The inputs, LON and LAT, describes a point in spherical polar
;   coordinates on the unit sphere.  The output is that point as a
;   unit 3-vector.
;
;   LON is the longitude angle, measured in degrees from +X, with
;   positive angles rotating through +Y.  The range of LON is
;   0 (+X) through 90 (+Y) through 360.
;
;   If DEC=0, LAT represents a colatitude angle, measured in
;   degrees from +Z.  The range of LAT is 0 (+Z) through 
;   180 (-Z).
;
;   If DEC=1, LAT represents a latitude angle ("declination"
;   in astronomy), measured in degrees from the XY equator (positive
;   toward +Z).  The range of LAT is -90 (-Z) through +90 (+Z).
;
;   ANGUNITVEC and UNITVECANG are functional inverses.
;   UNITVECANG(ANGUNITVEC(LON,LAT)) should produce the same LONLAT
;   pairs.
;
; INPUTS:
;
;  LON - input longitude values, scalar or vector.  See above.
;  LAT - input (co)latitude, scalar or vector. See above.
;
; RETURNS:
;
;  The resulting unit vector, either a 3-vector or a 3xN array for N
;  unit vectors.
;
;
; KEYWORD PARAMETERS:
;
;   DEC - if set, then the input LONLAT(1,*) component is latitude;
;         if not set then LONLAT(1,*) is a colatitude.
;
; EXAMPLE:
;
;   print, angunitvec([157.65924,80.052155])
;     ==> [-9.1103345E-01,3.7439942E-01,1.7275169E-01]
;     (compare to example in UNITVECANG)
;
; SEE ALSO
;   UNITVECANG, ANGUNITVEC, CROSSP, QTNORMALIZE
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 2012-10-02, CM
;
;  $Id: angunitvec.pro,v 1.2 2012/10/02 12:28:13 cmarkwar Exp $
;
;-
; Copyright (C) 1999, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   ARG_PRESENT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Determine whether output parameter has been passed (IDL4 compatibility)
;
; CALLING SEQUENCE:
;   PRESENT = ARG_PRESENT(ARG)
;
; DESCRIPTION: 
;
;   ARG_PRESENT tests whether an argument to a function or procedure
;   can be used as an output parameter.  The behavior of this function
;   is identical to that of the built-in ARG_PRESENT function in IDL
;   version 5 or greater, and is meant to give the same functionality
;   to programs in IDL 4.
;
;   An IDL procedure or function can use ARG_PRESENT to decide whether
;   the value of a positional or keyword parameter will be returned to
;   the calling procedure.  Generally, if the caller did not pass the
;   parameter then there is no need to compute the value to be
;   returned.
;
;   To be a valid output parameter, the caller must have passed a
;   named variable into which the result is stored.  If the caller
;   passed the parameter by value (e.g., an expression or a
;   subscripted array) the value cannot be returned and ARG_PRESENT
;   returns 0.
;
; INPUTS:
;
;   ARG - the parameter to be tested.  It can be either a positional
;         or a keyword parameter.  Passing a normal local variable
;         (i.e., not a passed parameter) will cause ARG_PRESENT to
;         return zero.
;
; RETURNS:
;
;   Returns a value of 1 if ARG is a valid output parameter, and a
;   value of 0 otherwise.
;
;
; EXAMPLE:
;
;   Consider the following procedure:
;      PRO TESTARG, ARG1
;        print, ARG_PRESENT(ARG1)
;      END
;
;   This procedure will print 1 when an ARG1 can be used as an output
;   parameter.  Here are some examples of the results of TESTARG.
;
;      IDL> testarg
;             0
;      IDL> testarg, x      
;             1
;      IDL> testarg, findgen(10)
;             0
;   
;   In the first case, no argument is passed, so ARG1 cannot be a
;   return variable.  In the second case, X is undefined, but it is
;   still a legal named variable capable of receiving an output
;   parameter.  In the third case, FINDGEN(10) is an expression which
;   cannot receive an output parameter.
;
; SEE ALSO:
;
;   ARG_PRESENT in IDL version 5
;
; MODIFICATION HISTORY:
;   Written, CM, 13 May 2000
;   Small documentation and bug fixes, CM, 04 Jul 2000
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   ARRDELETE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Remove a portion of an existing array.
;
; CALLING SEQUENCE:
;   NEWARR = ARRDELETE(INIT, [AT=POSITION,] [LENGTH=NELEM])
;
; DESCRIPTION: 
;
;   ARRDELETE will remove or excise a portion of an existing array,
;   INIT, and return it as NEWARR.  The returned array will never be
;   larger than the initial array.
;
;   By using the keywords AT and LENGTH, which describe the position
;   and number of elements to be excised respectively, any segment of
;   interest can be removed.  By default the first element is removed.
;
; INPUTS:
;
;   INIT - the initial array, which will have a portion deleted.  Any
;          data type, including structures, is allowed.  Regardless of
;          the dimensions of INIT, it is treated as a one-dimensional
;          array.  If OVERWRITE is not set, then INIT itself is
;          unmodified.
;
; KEYWORDS:
;
;   AT - a long integer indicating the position of the sub-array to be
;        deleted.  If AT is non-negative, then the deleted portion
;        will be NEWARR[AT:AT+LENGTH-1].  If AT is negative, then it
;        represents an index counting from then *end* of INIT,
;        starting at -1L.
;        Default: 0L (deletion begins with first element).
;
;  LENGTH - a long integer indicating the number of elements to be
;           removed.  
;
;  OVERWRITE - if set, then INIT will be overwritten in the process of
;              generating the new array.  Upon return, INIT will be
;              undefined.
;
;  COUNT - upon return, the number of elements in the resulting array.
;          If all of INIT would have been deleted, then -1L is
;          returned and COUNT is set to zero.
;
;  EMPTY1 - if set, then INIT is assumed to be empty (i.e., to have
;           zero elements).  The actual value passed as INIT is
;           ignored.
;
; RETURNS:
;
;   The new array, which is always one-dimensional.  If COUNT is zero,
;   then the scalar -1L is returned.
;
; SEE ALSO:
;
;   STORE_ARRAY in IDL Astronomy Library
;
; MODIFICATION HISTORY:
;   Written, CM, 02 Mar 2000
;   Added OVERWRITE and EMPTY1 keyword, CM 04 Mar 2000
;
;  $Id: arrdelete.pro,v 1.2 2001/03/25 18:10:41 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   ARRINSERT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Insert one array into another
;
; CALLING SEQUENCE:
;   NEWARR = ARRINSERT(INIT, INSERT, [AT=POSITION] )
;
; DESCRIPTION: 
;
;   ARRINSERT inserts the contents of one array (INSERT) into
;   another (INIT), and returns the new array (NEWARR).
;
;   ARRINSERT will handle empty lists, which are represented as
;   undefined variables.  If both input arrays are empty, then the
;   scalar -1L is returned, and the keyword COUNT is set to 0L.
;
; INPUTS:
;
;   INIT - the initial array, into which INSERT will be inserted.  Any
;          data type, including structures, is allowed.  Regardless of
;          the dimensions of INIT, it is treated as a one-dimensional
;          array.  If OVERWRITE is not set, then INIT itself is
;          unmodified.
;
;   INSERT - the array to be inserted into INIT, which must be of the
;            same or similar type to INIT.  If INSERT is empty, then
;            INIT is returned unchanged.  Regardless of the dimensions
;            of INSERT, it is treated as a one-dimensional array.
;
; KEYWORDS:
;
;    AT - a long integer indicating the position of the newly inserted
;         sub-array.  If AT is non-negative, then INSERT will appear
;         at NEWARR[AT].  If AT is negative, then INSERT will appear
;         at NEWARR[AT + (N+1)] where N is the number of elements in
;         INIT, which is to say if AT is negative, it indexes from the
;         end side of the array rather than the beginning.  Thus,
;         setting AT=-1 will concatenate INIT and INSERT.
;
;         Default: 0L (INSERT appears at beginning of INIT)
;
;   OVERWRITE - if set, then the initial array INIT will be
;               overwritten by the new array.  Upon exit INIT becomes
;               undefined.
;
;   COUNT - upon return, the number of elements in the resulting
;           array.
;
;  EMPTY1, EMPTY2 - if set, then INIT (for EMPTY1) or INSERT (for
;                   EMPTY2) are assumed to be empty (i.e., to have
;                   zero elements).  The actual values passed as INIT
;                   or INSERT are then ignored.
;
; RETURNS:
;
;   The new array, which is always one-dimensional.  If COUNT is zero,
;   then the scalar -1L is returned.
;
; EXAMPLE:
;
;   X = [1, 2, 3]
;   Y = [4, 5, 6, 7]
;
;   ; Insert Y at the beginning of X
;   result = arrinsert(x, y, at=0)
;      --> result = [4, 5, 6, 7, 1, 2, 3]
;
;   ; Insert Y in the middle of X
;   result = arrinsert(x, y, at=1)
;     --> result = [1, 4, 5, 6, 7, 2, 3]
;
;   ; Append Y at the end of X
;   result = arrinsert(x, y, at=-1)
;     --> result = [1, 2, 3, 4, 5, 6, 7]
;
; SEE ALSO:
;
;   ARRDELETE, STORE_ARRAY in IDL Astronomy Library
;
; MODIFICATION HISTORY:
;   Written, CM, 02 Mar 2000
;   Added OVERWRITE and EMPTY keywords, CM, 04 Mar 2000
;   Improved internal docs, and AT keyword docs, CM, 28 Sep 2000
;   Doc clarifications, CM, 29 Sep 2001
;   Added examples to documentation, CM, 06 Apr 2008
;
;  $Id: arrinsert.pro,v 1.4 2008/07/08 20:24:59 craigm Exp $
;
;-
; Copyright (C) 2000,2001,2008, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CHEBCOEF
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Estimate Chebyshev polynomial coefficients of a function on an interval
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   p = CHEBCOEF(FUNC, PRIVATE, FUNCTARGS=functargs, /DOUBLE, /EXPRESSION, $
;                PRECISION=prec, ERROR=err, NMAX=nmax, INTERVAL=interval, $
;                REDUCE_ALGORITHM=, STATUS=)
;
; DESCRIPTION:
;
;   CHEBCOEF estimates the coefficients for a finite sum of Chebyshev
;   polynomials approximating the function FUNC(x) over an interval.
;   The user can choose the desired precision and maximum number of
;   chebyshev coefficients.
;
;   This routine is intended for functions which can be evaluated to
;   full machine precision at arbitrary abcissae, and which are smooth
;   enough to ensure that the coefficients are a decreasing sequence.
;   For already-tabulated or potentially noisy data, the routines
;   CHEBGRID or CHEBFIT should be used instead.
;
;   The function to be approximated may either be the name of an IDL
;   function (the default behavior), or an IDL expression (using the
;   /EXPRESSION keyword).
;
;   The procedure uses a modified form of the classic algorithm for
;   determining the coefficients, which relies the orthogonality
;   relation for Chebyshev polynomials.  The interval [a,b] is
;   subdivided successively into sets of subintervals of length
;   2^(-k)*(b-a),(k = 0,1,2...). After each subdivision the
;   orthogonality properties of the Chebyshev polynomials with respect
;   to summation over equally-spaced points are used to compute two
;   sets of approximate values of the coefficients cj, one set
;   computed using the end-points of the subintervals, and one set
;   using the mid-points.  Certain convergence requirements must be
;   met before terminating.  If the routine fails to converge with 64
;   coefficents, then the current best-fitting coefficients are
;   returned, along with an error estimate in the ERROR keyword.
;   CHEBCOEF never returns more than 64 coefficients.
;
;   The coefficients may be further refined.  If the keyword
;   REDUCE_ALGORITHM is set to a value of 1, then any high order
;   coefficients below a certain threshold are discarded.  If
;   REDUCE_ALGORITHM is set to 2 (the default), then all coefficients
;   below the threshold are discarded rather than just the high order
;   ones.  The threshold is determined by the PRECISION keyword.
;
; INPUTS:
;
;   FUNC - a scalar string, the name of the function to be
;          approximated, or an IDL string containing an expression to
;          be approximated (if /EXPRESSION is set).
;
;  PRIVATE - any optional variable to be passed on to the function to
;            be integrated.  For functions, PRIVATE is passed as the
;            second positional parameter; for expressions, PRIVATE can
;            be referenced by the variable 'P'.  CHEBCOEF does not
;            examine or alter PRIVATE.
;
; RETURNS:
;
;   An array of Chebyshev coefficients which can be passed to
;   CHEBEVAL.  NOTE: the convention employed here is such that the
;   constant term in the expansion is P(0)*T0(x) (i.e., the convention
;   of Luke), and not P(0)/2 * T0(x).
;
; KEYWORD PARAMETERS:
;
;   DOUBLE - if set, then computations are done in double precision
;            rather than single precision.
;
;   ERROR - upon return, this keyword contains an estimate of the
;           maximum absolute error in the approximation.
;
;   EXPRESSION - if set, then FUNC is an IDL expression to be
;                approximated, rather than the name of a function.
;
;   FUNCTARGS - A structure which contains the parameters to be passed
;               to the user-supplied function specified by FUNCT via
;               the _EXTRA mechanism.  This is the way you can pass
;               additional data to your user-supplied function without
;               using common blocks.  By default, no extra parameters
;               are passed to the user-supplied function.
;
;   INTERVAL - a 2-element vector describing the interval over which
;              the polynomial is to be evaluated.
;              Default: [-1, 1]
;
;   NMAX - a scalar, the maximum number of coefficients to be
;          estimated.   This number may not exceed 64. 
;          Default: 64
;
;   PRECISION - a scalar, the requested precision in the
;               approximation.  Any terms which do not contribute
;               significantly, as defined by this threshold, are
;               discarded.  If the function to be estimated is not
;               well-behaved, then the precision is not guaranteed to
;               reach the desired level.  Default: 1E-7
;
;   REDUCE_ALGORITHM - a scalar integer, describes how insignificant
;               terms are removed from the fit.  If 0, then all terms
;               are kept, and none are dicarded.  If 1, then only
;               trailing terms less than PRECISION are discarded.  If
;               2, then both trailing and intermediate terms less than
;               PRECISION are discarded.
;               Default: 2
;
;   STATUS - upon return, this keyword contains information about the
;            status of the approximation.  A value of -1 indicates bad
;            input values; a value of 0 indicates the required
;            accuracy was not obtained; a value of 1 indicates
;            success.
;
; EXAMPLE:
;
;   x = dindgen(1000)/100     ; Range of 0 to 10
;   p = chebcoef('COS(x)', /expr, interval=[0d, 10d])  ;; Compute coefs
;   y = chebeval(x, p, interval=[0d,10d])              ;; Eval Cheby poly
;   plot, x, y - cos(x)       ; Plot residuals
;
; REFERENCES:
;
;   Abramowitz, M. & Stegun, I., 1965, *Handbook of Mathematical
;     Functions*, 1965, U.S. Government Printing Office, Washington,
;     D.C. (Applied Mathematical Series 55)
;   CERN, 1995, CERN Program Library, Function E406
;   Luke, Y. L., *The Special Functions and Their Approximations*,
;     1969, Academic Press, New York
;
; MODIFICATION HISTORY:
;   Written and documented, CM, June 2001
;   Copyright license terms changed, CM, 30 Dec 2001
;   Added usage message, CM, 20 Mar 2002
;   Changed docs slightly, CM, 25 Mar 2002
;
;  $Id: chebcoef.pro,v 1.6 2002/05/03 18:40:27 craigm Exp $
;
;-
; Copyright (C) 2001, 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Evaluate a user-supplied expression
function chebcoef_eval, x, p, expression=expr, _EXTRA=extra
  y = 0
  cmd = 'Y = '+expr
  dummy = execute(cmd)
  return, y
end

function chebcoef, f0, priv, functargs=fa, double=double, error=err, $
                   nmax=nmax, interval=interval, precision=prec0, $
                   expression=expr, reduce_algorithm=redalg0, $
                   status=status, indices=igood

  if n_params() EQ 0 then begin
      message, 'USAGE:', /info
      message, 'P = CHEBCOEF(FUNCT, [PRIV,] INTERVAL=[a,b], NMAX=...)', /info
      return, !values.d_nan
  endif

  sz = size(f0)
  err = -1
  if sz(sz(0)+1) NE 7 OR n_elements(f0) NE 1 then begin
      NO_FUNCT:
      message, 'ERROR: FUNCT must be a scalar string', /info
      return, 0
  endif

  ;; Check for empty string
  f = strtrim(f0(0),2)
  if f EQ '' then goto, NO_FUNCT

  ;; Prepare for EXPRESSION if requested
  if keyword_set(expr) then begin
      f = 'CHEBCOEF_EVAL'
      fa = {expression: strtrim(f0(0),2)}
  endif else begin
      f = strtrim(f0(0),2)
  endelse

  ;; Handle error conditions gracefully
  if NOT keyword_set(nocatch) then begin
      catch, catcherror
      if catcherror NE 0 then begin
          catch, /cancel
          message, 'Error detected while approximating '+f, /info
          message, !err_string, /info

          errmsg = 0
          if NOT keyword_set(expr) then begin
              f1 = byte(strupcase(strtrim(f0(0),2)))
              ca = (byte('A'))(0) 
              cz = (byte('Z'))(0) 
              c0 = (byte('0'))(0) 
              c9 = (byte('9'))(0) 
              c_ = (byte('_'))(0) 
              wh = where((f1 GE ca AND f1 LE cz) EQ 0 AND f1 NE c_ $
                         AND (f1 GE c0 AND f1 LE c9) EQ 0, ct)
              if ct GT 0 OR (f1(0) GE c0 AND f1(0) LE c9) then begin
                  message, ('FUNCT appears to be an expression.  Did you '+$
                            'intend to pass the /EXPRESSION keyword?'), /info
                  errmsg = 1
              endif
          endif
          if errmsg EQ 0 then $
            message, ('Please verify that function works and conforms to '+$
                      'the documentation'), /info
          ier = -1L
          return, 0L
      endif
  endif

  if n_elements(prec0) EQ 0 then prec = 1e-7 else prec = prec0(0)
  zero = prec*0.
  if keyword_set(double) then zero = 0D
  if n_elements(interval) LT 2 then interval = zero + [-1., 1.]
  if n_elements(redalg0) EQ 0 then redalg = 2 else redalg = floor(redalg0(0))
  status = -1
  
  a = interval(0)
  b = interval(1)
  hf = zero + 0.5
  eps = prec
  z1 = zero + 1
  z2 = zero + 2
  sz = size(zero)
  if sz(sz(0)+1) EQ 5 then pi = !dpi else pi = !pi

  x0 = [a, b]
  if n_elements(priv) GT 0 then begin
      if n_elements(fa) GT 0 then fv = call_function(f, x0, priv, _EXTRA=fa) $
      else                        fv = call_function(f, x0, priv)
  endif else begin
      if n_elements(fa) GT 0 then fv = call_function(f, x0, _EXTRA=fa) $
      else                        fv = call_function(f, x0)
  endelse
  

  ALFA=HF*(B-A)
  BETA=HF*(B+A)
  C1=fv(0)
  C2=fv(1)
  AC = [C2+C1, C2-C1]
  BC = AC*0

  for i = 1, 7 do begin
      I1=2^(I-1)
      I2=I1-1
      I3=2*I1
      C1=Z2/I1
      C2=PI/I1

      jj = dindgen(i2+1)
      x = alfa*cos((jj+hf)*c2)+beta
      if n_elements(priv) GT 0 then begin
          if n_elements(fa) GT 0 then fv = call_function(f, x, priv, $
                                                         _EXTRA=fa) $
          else                        fv = call_function(f, x, priv)
      endif else begin
          if n_elements(fa) GT 0 then fv = call_function(f, x, _EXTRA=fa) $
          else                        fv = call_function(f, x)
      endelse
      c = fv

      ;; Compute B-coefficients
      for j = 0L, i2 do begin
          F1=J*C2
          F2=-HF*F1
      
          C3=2*COS(F1)
          A2=zero
          A1=zero
          A0=C(I2)

          for K = I2-1,0L,-1 do begin
              A2=A1
              A1=A0
              A0=C(K)+C3*A1-A2
          endfor
          BC(J)=C1*(A0*COS(F1+F2)-A1*COS(F2))
          BC(I1)=zero
      endfor

      c = hf*[ac(0:i1-1)+bc(0:i1-1), rotate(ac(0:i1)-bc(0:i1),2)]
      cc = abs(c)
      cmx = max(cc)
      
      if (CMX GT 0) THEN begin
          CMX=1/CMX
          CC(I3)=HF*CC(I3)
          A0=CC(I2)*CMX
          A1=CC(I1)*CMX
          for J = I1+2,I3 do begin
              A2=CC(J)*CMX
              IF(A0 LE EPS AND A1 LE EPS AND A2 LE EPS) THEN $
                goto, CHEB9
              A0=A1
              A1=A2
          endfor
      ENDIF

      ;; DOUBLE THE NUMBER OF COEFFICIENTS.      
      if i LT 7 then begin
          ac = c(0:i3)
          bc = ac*0
      endif
  endfor

  ;; REQUIRED ACCURACY NOT OBTAINED

  NC=64
  DELTA=total(abs(c(60:nc)))
  message, 'WARNING: Required accuracy not obtained', /info
  status = 0
  goto, CLEANUP

  CHEB9:
  ;; REQUIRED ACCURACY OBTAINED
  ;; SUM NEGLECTED TERMS IN EXPANSION

  status = 1
  DELTA=total(cc(j:i3))

  ;;  CHECK IF FURTHER REDUCTION OF COEFFICIENTS IS POSSIBLE.

  NC=J-1
  REST=EPS-DELTA
  IF (REST GT 0) AND redalg GT 0 THEN begin
      while (CC(NC) LT REST) do begin
          DELTA=DELTA+CC(NC)
          REST=REST-CC(NC)
          NC=NC-1
      endwhile
  ENDIF

  CLEANUP:
  C(0)=HF*C(0)
  p = c(0:nc)
  rest = eps - delta

  if redalg EQ 2 then begin
      wh = where(cc(0:nc) LT prec, ct)
      i = ct-1
      while (i GE 0) AND ((rest GT 0) OR (status EQ 1)) do begin
          delta = delta + cc(wh(i))
          rest  = rest - cc(wh(i))
          p(wh(i)) = 0
          i = i - 1
      endwhile
  endif

  DONE:
  igood = where(p NE 0)
  err = delta
  RETURN, p
end

;+
; NAME:
;   CHEBEVAL
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Evaluate a Chebyshev polynomial on an interval, given the coefficients
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   y = CHEBEVAL(X, P, INTERVAL=interval, DERIVATIVE=deriv)
;
; DESCRIPTION:
;
;   CHEBEVAL computes the values of a Chebyshev polynomial function at
;   specified abcissae, over the interval [a,b].  The user must supply
;   the abcissae and the polynomial coefficients.  The function is of
;   the form:
;
;               N
;       y(x) = Sum p_n T_n(x*)     x in [a,b]
;              i=0
;
;   Where T_n(x*) are the orthogonal Chebyshev polynomials of the
;   first kind, defined on the interval [-1,1] and p_n are the
;   coefficients.  The scaled variable x* is defined on the [-1,1]
;   interval such that (x*) = (2*x - a - b)/(b - a), and x is defined
;   on the [a,b] interval.
;
;   The derivative of the function may be computed simultaneously
;   using the DERIVATIVE keyword.  
;
;   The is some ambiguity about the definition of the first
;   coefficient, p_0, namely, the use of p_0 vs. the use of p_0/2.
;   The p_0 definition of Luke is used in this function.
;
; INPUTS:
;
;   X - a numerical scalar or vector, the abcissae at which to
;       evaluate the polynomial.  If INTERVAL is specified, then all
;       values of X must lie within the interval.
;
;   P - a vector, the Chebyshev polynomial coefficients, as returned
;       by CHEBFIT or CHEBCOEF.
;
; RETURNS:
;
;   An array of function values, evaluated at the abcissae.  The
;   numeric precision is the greater of X or P.
;
; KEYWORD PARAMETERS:
;
;   DERIVATIVE - upon return, a vector containing the derivative of
;                the function at each abcissa is returned in this
;                keyword.
;
;   INTERVAL - a 2-element vector describing the interval over which
;              the polynomial is to be evaluated.
;              Default: [-1, 1]
;
; EXAMPLE:
;
;   x = dindgen(1000)/100     ; Range of 0 to 10
;   p = chebcoef('COS(x)', /expr, interval=[0d, 10d])  ;; Compute coefs
;   y = chebeval(x, p, interval=[0d,10d])              ;; Eval Cheby poly
;   plot, x, y - cos(x)       ; Plot residuals
;
; REFERENCES:
;
;   Abramowitz, M. & Stegun, I., 1965, *Handbook of Mathematical
;     Functions*, 1965, U.S. Government Printing Office, Washington,
;     D.C. (Applied Mathematical Series 55)
;   CERN, 1995, CERN Program Library, Function E407
;   Luke, Y. L., *The Special Functions and Their Approximations*,
;     1969, Academic Press, New York
;
; MODIFICATION HISTORY:
;   Written and documented, CM, June 2001
;   Copyright license terms changed, CM, 30 Dec 2001
;   Added usage message, CM, 20 Mar 2002
;   Return a vector even when P has one element, CM, 22 Nov 2004
;   Fix bug in evaluation of derivatives, CM, 22 Nov 2004
;
;  $Id: chebeval.pro,v 1.6 2004/11/22 07:08:00 craigm Exp $
;
;-
; Copyright (C) 2001, 2002, 2004, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CHEBFIT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Fit Chebyshev polynomial coefficients to a tabulated function
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   p = CHEBFIT(X, Y, ERR, INTERVAL=interval, NMAX=nmax,
;               PRECISION=prec, /EVEN, /ODD, REDUCE_ALGORITHM=)
;
; DESCRIPTION:
;
;   CHEBFIT fits a series of Chebyshev polynomials to a set of
;   tabulated and possibly noisy data points.  The functions MPFIT and
;   CHEBEVAL, available from the above web page, must also be in your
;   IDL path for this function to work properly.  The user can choose
;   the desired precision and maximum number of chebyshev
;   coefficients.
;
;   This function is intended for use on already-tabulated data which
;   are potentially noisy.  The user should never expect more than
;   NPOINTS terms, where NPOINTS is the number of (x,y) pairs.  For
;   functions which can be evaluated to full machine precision at
;   arbitrary abcissae, the routine CHEBCOEF should be used instead.
;   For exact data tabulated on a regular grid, the routine CHEBGRID
;   should be tried.
;
;   The user can also specify that the function is even or odd, using
;   the keywords EVEN or ODD.  This saves computation time because
;   certain terms in the expansion can be ignored.  For the purposes
;   of this function even and odd refer to the symmetry about the
;   center of the interval.
;
;   The algorithm is employed in three steps.  In the first step, the
;   coefficients are estimated at a crude level.  In the second step,
;   it is determined whether certain coefficients are deemed
;   "ignoreable", i.e., they do not contribute significantly to the
;   function and are discarded.  The operation of this step is
;   determined by the REDUCE_ALGORITHM keyword.  Finally, the
;   remaining "good" coefficients are re-fitted to achieve the best
;   fit.
;
; INPUTS:
;
;   X, Y - the x- and y- tabulated values to be fitted.
;
;   ERR - (optional) the y-error bar associated with each (x,y) pair.
;         Default: 1
;
; RETURNS:
;
;   An array of Chebyshev coefficients which can be passed to
;   CHEBEVAL.  NOTE: the convention employed here is such that the
;   constant term in the expansion is P(0)*T0(x) (i.e., the convention
;   of Luke), and not P(0)/2 * T0(x).
;
; KEYWORD PARAMETERS:
;
;   EVEN, ODD - if set, then the fitting routine assumes the function
;               is even or odd, about the center of the interval.
;
;   INTERVAL - a 2-element vector describing the interval over which
;              the polynomial is to be evaluated.
;              Default: [-1, 1]
;
;   NMAX - a scalar, the maximum number of polynomial terms to be
;          fitted at one time.
;          Default: 16
;
;   PRECISION - a scalar, the requested precision in the fit.  Any
;               terms which do not contribute significantly, as
;               defined by this threshold, are discarded.  If the
;               function to be fitted is not well-behaved, then the
;               precision is not guaranteed to reach the desired
;               level.
;               Default: 1E-7
;
;   REDUCE_ALGORITHM - a scalar integer, describes how insignificant
;               terms are removed from the fit.  If 0, then all terms
;               are kept, and none are dicarded.  If 1, then only
;               trailing terms less than PRECISION are discarded.  If
;               2, then both trailing and intermediate terms less than
;               PRECISION are discarded.
;               Default: 2
;
; EXAMPLE:
;
;   x = dindgen(1000)/100     ; Range of 0 to 10
;   y = cos(x) + randomn(seed,1000)*0.01  ; Function with some noise
;   p = chebfit(x, y, interval=[0d,10d])
;   plot, x, y - chebeval(x,p, interval=[0d,10d])
;
; REFERENCES:
;
;   Abramowitz, M. & Stegun, I., 1965, *Handbook of Mathematical
;     Functions*, 1965, U.S. Government Printing Office, Washington,
;     D.C. (Applied Mathematical Series 55)
;   CERN, 1995, CERN Program Library, Function E407
;   Luke, Y. L., *The Special Functions and Their Approximations*,
;     1969, Academic Press, New York
;
; MODIFICATION HISTORY:
;   Written and documented, CM, June 2001
;   Copyright license terms changed, CM, 30 Dec 2001
;   Added usage message, CM, 20 Mar 2002
;   Slight docs change, CM, 25 Mar 2002
;
;  $Id: chebfit.pro,v 1.7 2003/07/20 05:53:44 craigm Exp $
;
;-
; Copyright (C) 2001, 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Compute residuals for MPFIT
function chebfit_eval, p, interval=interval, nterms=nterms, igood=igood, $
                       _EXTRA=extra

  common chebfit_common, x, y, err

  if n_elements(igood) EQ 0 then begin
      p1 = p
  endif else begin
      p1 = replicate(p(0)*0, nterms)
      p1(igood) = p
  endelse

  ;; Compute the Chebyshev polynomial
  f = chebeval(x, p1, interval=interval)

  ;; Compute the deviates, applying either errors or weights
  if n_elements(err) GT 0 then begin
      result = (y-f)/err
  endif else if n_elements(wts) GT 0 then begin
      result = (y-f)*wts
  endif else begin
      result = (y-f)
  endelse
  
  ;; Make sure the returned result is one-dimensional.
  result = reform(result, n_elements(result), /overwrite)
  return, result
end

function chebfit, x, y, err, nmax=nterms0, interval=interval, $
                  precision=prec, even=even, odd=odd, quiet=quiet, $
                  initialize=init, reduce_algorithm=redalg0, $
                  indices=igood, nocatch=nocatch, $
                  yfit=yfit, perror=perror, bestnorm=bestnorm, dof=dof

  if n_params() EQ 0 then begin
      message, 'USAGE:', /info
      message, 'P = CHEBFIT(X, Y, ERR, INTERVAL=[a,b], NMAX=, ...)', /info
      return, !values.d_nan
  endif

  if n_elements(nterms0) EQ 0 then nterms = 16L $
  else                             nterms = floor(nterms0(0)) > 2L
  nterms = nterms < n_elements(x)
  if n_elements(interval) LT 2 then interval = [-1., 1.]
  if n_elements(prec) EQ 0 then prec = 1.e-7
  if n_elements(redalg0) EQ 0 then redalg = 2 else redalg = floor(redalg0(0))
  if n_elements(quiet) EQ 0 then quiet = 1

  ;; Handle error conditions gracefully
  if NOT keyword_set(nocatch) then begin
      catch, catcherror
      if catcherror NE 0 then begin
          catch, /cancel
          message, 'Error detected while fitting', /info
          message, !err_string, /info
          ier = -1L
          return, 0L
      endif
  endif

  if n_elements(p) LT nterms OR keyword_set(init) then begin
      p = replicate(x(0)*0 + 1, nterms) / (findgen(nterms)+1)^2
      p(0) = total(y)/n_elements(y)
      ;; If mean is *exactly* zero, then shift it off slightly
      if p(0) EQ 0 then p(0) = sqrt(total(y^2))/n_elements(y)/10
  endif
  p0 = p
  igood = lindgen(nterms)

  if keyword_set(even) OR keyword_set(odd) then $
    igood = lindgen(n_elements(p)/2)*2 + keyword_set(odd)
  nt = min([nterms, max(igood)+1])

  ;; Cancel out old common entries
  common chebfit_common, xc, yc, errc
  xc   = 0 & dummy = temporary(xc)
  yc   = 0 & dummy = temporary(yc)
  errc = 0 & dummy = temporary(errc)
  
  xc = x
  yc = y
  if n_elements(err) GT 0 then begin
      errc = err
  endif

  fa = {interval: interval, igood: igood, nterms: nt}
  p1 = mpfit('CHEBFIT_EVAL', p0(igood), functargs=fa, maxiter=5, quiet=quiet)
  p0(igood) = p1

  ;; Look for and remove the insignificant terms from the fit
  if redalg GT 0 then begin
      wh = where(abs(p1) GT prec(0), ct)
      if ct EQ 0 then begin
          ALL_ZERO:
          message, 'WARNING: no significant Chebyshev terms were detected', $
            /info
          p = p0*0
          return, 0L
      endif
      if max(wh) LT n_elements(igood)-1 then begin
          imax = max(wh)
          igood = igood(0:imax)
          p1 = p1(0:imax)
      endif

      if redalg EQ 2 then begin
          wh = where(abs(p1) GT 0.1*prec, ct)
          if ct EQ 0 then goto, ALL_ZERO
          igood = igood(wh)
          p1 = p1(wh)
      endif
  endif

  nt = min([nterms, max(igood)+1])
  fa = {interval: interval, igood: igood, nterms: nt}
  p2 = mpfit('CHEBFIT_EVAL', p1, functargs=fa, maxiter=10, quiet=quiet, $
             perror=dp2, bestnorm=bestnorm, dof=dof)

  xc = 0 & yc = 0 & errc = 0
  p = p0*0 
  perror = p
  p(igood) = p2
  perror(igood) = dp2

  if arg_present(yfit) then $
    yfit = chebeval(x, p, interval=interval)

  return, p
end
;+
; NAME:
;   CHEBGRID
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Estimate Chebyshev polynomial coefficients of a function on a grid
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   p = CHEBGRID(T, X, [ DXDT, NPOINTS=, NPOLY=, NGRANULE= , $
;                RMS=, DRMS=, RESIDUALS=, DRESIDUALS= , $
;                XMATRIX=, DXMATRIX=, RESET=, 
;                DERIV_WEIGHT= ] )
;
; DESCRIPTION:
;
;   CHEBGRID estimates the coefficients for a finite sum of Chebyshev
;   polynomials approximating a continuous tabulated function over an
;   interval.  The function (and optionally its derivative) must be
;   tabulated on a regularly sampled grid.  The implementation of this
;   function is taken from a method described by X. X. Newhall, used
;   in estimating coefficients for ephemerides in the solar system.
;
;   The tabulated function is assumed to be continuous over the entire
;   interval.  A Chebyshev series is fitted to the function over small
;   segments, called granules.  The size of each granule, the number
;   of points in each granule, and the number of Chebyshev polynomials
;   are all configurable.
;
;   Users may specify either the function alone, or the function and
;   its first derivative.  By also giving the tabulated derivative, a
;   more accurate Chebyshev polynomial can be developed.  Aside from
;   the constraints mentioned in the next paragraph, the polynomial
;   that is returned is the best-fit polynomial in a least-squares
;   sense.
;
;   Here is a definition of terms:
;
;      GRANULE - a single continuous fitted segment.  The length of the
;         granule, NGRANULE, is specified in units of the tabulated
;         grid size.  Because of the continuity requirements developed
;         below, granules will always overlap at their endpoints.
;         Thus, then length of a granule should be a factor of
;         N_ELEMENTS(X)-1.  For simple functions over short intervals,
;         the granule size can be equal to N_ELEMENTS(X)-1
;
;      NUMBER OF POINTS the number of points, NPOINTS, within a
;         granule to be fitted to the polynomial, not necessarily
;         equal to the granule size.  The greater the number of
;         points, the more computation time and storage is required.
;         This number *must* be a factor of NGRANULE.  Typically
;         NPOINTS is a number between 8 and 12.  Because of the
;         single-point overlap between granules (see below), the
;         actual number of points per fit is NPOINTS+1.
;
;      NUMBER OF POLYNOMIALS the number of Chebyshev polynomial terms,
;         NPOLYNOMIAL, to be fitted per granule.  The greater the
;         number of polynomial terms, the more computation time and
;         storage is required, but also the greater the approximating
;         precision of the fit.
;
;   The particular set of Chebyshev polynomial coefficients developed
;   by this function have some special properties.  If both the
;   function and its derivative are specified, then the value and
;   derivative of the interpolating polynomial at the granule
;   endpoints will be exactly equal to the tabulated endpoint values.
;   This feature allows many approximations to be strung together
;   piecewise, and the function value and first derivative will be
;   continuous across granule boundaries.
;
;   If only the function value is specified, then only the function
;   value will be continuous at the granule endpoints, and not the
;   derivative.
;
;   An extensive set of statistics are computed to assess the quality
;   of the Chebyshev polynomial fit.  The keywords RESIDUALS and
;   DRESIDUALS return the residuals of the fit after subtracting the
;   interpolation.  The RMS and DRMS keywords return the root mean
;   squared deviations between data and model.
;
;   If the user does not know how many granules, points, or polynomial
;   coefficients to use, then he or she should try several
;   combinations and see which minimizes the r.m.s. value with the
;   fewest number of coefficients.
;
;   If the XMATRIX and DXMATRIX keywords are passed, then CHEBGRID
;   attempts to avoid recomputing several of the matrices it uses in
;   estimating the coefficients.  If multiple calls to CHEBGRID are to
;   be made, some compution time savings can be made.  In the first
;   call CHEBGRID the required matrices are computed and returned.  In
;   subsequent calls, CHEBGRID detects the XMATRIX and DXMATRIX
;   keyword values and uses those values if it can.
;
;   The user can also estimate their own coefficients.  The matrices
;   returned are (NPOINTS+1)x(NPOLYNOMIAL).  The coefficients from a
;   NPOINTS+1 tabulation, X, are found by:
;
;      PCHEB = XMATRIX ## X  +  DXMATRIX ## DXDT
;
;   if derivative information is known, or
;
;      PCHEB = XMATRIX ## X
;
;   if no derivative information is known.  [ Note: the matrices are
;   different, depending on whether derivative information is known or
;   not. ]
;
;   
; INPUTS:
;
;   T - array of regularly sampled *independent* variables.  The number
;       of elements in T should be a multiple of NGRANULE, plus one.
;
;   X - array of regularly sampled *dependent* variables.  The number
;       of elements in X should be equal to the number of elements in
;       T.
;
;   DXDT - optionally, a tabulated array of first derivatives of X
;          with respect to T, at the same grid points.
;
; KEYWORD PARAMETERS:
;
;   NGRANULE - size of a "granule", in grid intervals.  NGRANULE must
;              be at least 2, and a factor of N_ELEMENTS(T)-1.
;              Default: 8
;
;   NPOINTS - number of points per granule that are fitted.  NPOINTS
;             must be at least 2, and a factor of NGRANULE. 
;             Default: NGRANULE
;
;   NPOLYNOMIAL - number of Chebyshev polynomial terms per fit.
;                 NPOLYNOMIAL must be at least 2 and less than
;                 2*(NPOINTS+1), when derivative information is
;                 specified; or less than NPOINTS+1, when no
;                 derivative information is specified.
;                 Default: 7
;
;  RESIDUALS - upon return, an array of size N_ELEMENTS(T), with
;              residuals of the tabulated function minus the
;              interpolated function.
;
;  DRESIDUALS - same as RESIDUALS, but for the function's first
;               derivative.
;
;  RMS - upon return, the root mean square of the function value
;        residuals.
;
;  DRMS - same as RMS, but for the function's first derivative.
;
;  XMATRIX - upon return, the matrix used to compute Chebyshev
;            polynomial coefficients from the function value.
;
;            Upon input, CHEBGRID determines if XMATRIX will apply to
;            the data, and if so, XMATRIX is reused rather than
;            computed.  If XMATRIX cannot be reused, then it is
;            computed afresh, and the new value is returned in the
;            XMATRIX keyword.
;
;            The user should not modify the contents of this array.
;
;  DXMATRIX - same as XMATRIX, but for the function's first
;             derivative.
;
;  RESET - if set, force a recomputation of XMATRIX and/or DXMATRIX.
;
;  DERIV_WEIGHT - amount of weight to give to function derivative,
;                 relative to the function value.
;                 Default: 0.16d
;
;
; RETURNS:
;
;   An array of coefficient values.  The dimensions of the array are
;   NPOLYNOMIALxNSEGS, where NSEGS is the number of granules in the
;   entire interval.
;
;
; EXAMPLE:
;
;   ;; Estimate Chebyshev coefficients for the function SIN(X), on the
;   ;; interval [-1,+1].  
;   xx = dindgen(9)/4d - 1d   ;; Regular grid from -1 to 1 (9 points)
;   yy = sin(xx)              ;; Function values, sin(x), ...
;   dy = cos(xx)              ;; ... and derivatives
;
;   ;; Estimate coefficients using CHEBGRID (single granule of 8 intervals)
;   p = chebgrid(xx, yy, dy, npoints=8, ngranule=8, npoly=10)
;
;   xxx = dindgen(1001)/500 - 1d   ;; New grid for testing
;   res = sin(xxx) - chebeval(xxx, p)
;   plot, xxx, res
;
;   ;; Same as example above, except extended range to [-1, +15],
;   using eight granules.
;   xx2 = dindgen(65)/4d - 1
;   yy2 = sin(xx2)
;   dy2 = cos(xx2)
;   p = chebgrid(xx2, yy2, dy2, ngranule=8, npoint=8, npoly=10)
;   help, p
;       P               DOUBLE    = Array[10, 8]
;   ;; (i.e., 10 polynomial coefficients over 8 granules)
;
;
; REFERENCES:
;
;   Abramowitz, M. & Stegun, I., 1965, *Handbook of Mathematical
;     Functions*, 1965, U.S. Government Printing Office, Washington,
;     D.C. (Applied Mathematical Series 55)
;   Newhall, X. X. 1989, Celestial Mechanics, 45, p. 305-310
;
; MODIFICATION HISTORY:
;   Written, CM, Feb 2002
;   Documented, CM, 24 Mar 2002
;   Corrected documentation, CM, 28 Apr 2002
;   Typo correction, CM, 10 Oct 2002
;
;  $Id: chebgrid.pro,v 1.5 2002/11/07 00:15:23 craigm Exp $
;
;-
; Copyright (C) 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Utility function: compute XMATRIX and DXMATRIX using Newhall approach
pro chebpcmat, npts, npoly, xmat, vmat, dweight=weight0

  ;; n0 is the number of intervals in Cheb approx.
  n0 = npts - 1
  if n_elements(weight0) EQ 0 then $
    weight = 0.16d $
  else $
    weight = weight0(0)

  tmat = dblarr(npoly, npts)
  tdot = tmat

  cj = dblarr(npoly)
  xj = 1d - 2d*dindgen(npts)/n0
  for i = 0, npoly-1 do begin
      cj(*) = 0 & cj(i) = 1
      tmat(i,*) = chebeval(xj, cj, deriv=v)
      tdot(i,*) = v
  endfor

  ;; Form matrix T*W
  tw = dblarr(2,npts,npoly)
  tw(0,*,*) = transpose(tmat)
  tw(1,*,*) = transpose(tdot) * weight

  ;; Form matrix T*WT
  twt = reform(tw(0,*,*),npts,npoly) ## tmat + $
    reform(tw(1,*,*),npts,npoly) ## tdot

  tw  = reform(tw, 2*npts, npoly, /overwrite)
  twt = reform(twt, npoly, npoly, /overwrite)

  ;; Augment matrix T*W to get matrix C2
  c2 = dblarr(2*npts,npoly+4)
  c2(*,0:npoly-1) = tw
  c2(0,npoly)          = 1 & c2(1,npoly+1)        = 1
  c2(2*npts-2,npoly+2) = 1 & c2(2*npts-1,npoly+3) = 1

  ;; Augment matrix T*WT to get the matrix C1
  c1 = dblarr(npoly+4,npoly+4)
  c1(0:npoly-1,0:npoly-1) = twt

  c1(0:npoly-1,npoly+0) = tmat(*,0)
  c1(0:npoly-1,npoly+1) = tdot(*,0)
  c1(0:npoly-1,npoly+2) = tmat(*,npts-1)
  c1(0:npoly-1,npoly+3) = tdot(*,npts-1)

  c1(npoly:*,0:npoly-1) = transpose(c1(0:npoly-1,npoly:*))

  ;; Compute matrix C1^(-1)
  c1inv = invert(c1)
  ;; Compute matrix C1^(-1) C2
  c1c2 = c1inv ## c2

  c1c2 = reform(c1c2, 2,npts,npoly+4)
  c1c2 = reverse(c1c2,2)
  c1c2 = reform(c1c2, 2*npts,npoly+4)

  ii = lindgen(npts)*2
  xmat = c1c2(ii,0:npoly-1)   ;; Split into terms multiplying Y and VY
  vmat = c1c2(ii+1,0:npoly-1)

  return
end

;; Utility function: compute XMATRIX only, using only the constraint
;; on the function values at the endpoints.
pro chebpcmat_xonly, npts, npoly, xmat

  ;; n0 is the number of points in Cheb approx.
  n0 = npts - 1
  
  tmat = dblarr(npoly, npts)

  cj = dblarr(npoly)
  xj = 1d - 2d*dindgen(npts)/n0
  for i = 0, npoly-1 do begin
      cj(*) = 0 & cj(i) = 1
      tmat(i,*) = chebeval(xj, cj, deriv=v)
  endfor

  ;; Augment matrix T to get matrix C2
  c2 = dblarr(npts,npoly+2)
  c2(*,0:npoly-1) = transpose(tmat)
  c2(0,npoly)     = 1
  c2(npts-1,npoly+1) = 1

  ;; Augment matrix T*WT to get the matrix C1
  c1 = dblarr(npoly+2,npoly+2)
  c1(0:npoly-1,0:npoly-1) = transpose(tmat) ## tmat

  c1(0:npoly-1,npoly+0) = tmat(*,0)
  c1(0:npoly-1,npoly+1) = tmat(*,npts-1)

  c1(npoly:*,0:npoly-1) = transpose(c1(0:npoly-1,npoly:*))

  ;; Compute matrix C1^(-1)
  c1inv = invert(c1)
  ;; Compute matrix C1^(-1) C2
  c1c2 = c1inv ## c2

  c1c2 = reform(c1c2, npts,npoly+2)
  c1c2 = reverse(c1c2,1)
  xmat = c1c2(*,0:npoly-1)

  return
end

function chebgrid, t, x, dxdt, ngranule=ngran0, npoints=npts0, $
                   npolynomial=npoly0, deriv_weight=dweight0, $
                   rms=rms, drms=drms, residuals=resid, dresiduals=dresid, $
                   xmatrix=xmatrix, dxmatrix=dxmatrix, reset=reset

  ;; Default processing
  if n_elements(ngran0) EQ 0 then ngran = 8 $
  else ngran = round(ngran0(0)) > 2

  if n_elements(npts0) EQ 0 then npts = ngran $
  else npts = round(npts0(0)) > 2

  if n_elements(npoly0) EQ 0 then npoly = 7 $
  else npoly = round(npoly0(0)) > 2

  ;; Error checking
  if ngran LT npts then begin
      message, 'ERROR: Granule size ('+strtrim(ngran,2)+') is too '+ $
        'small for number of samples ('+strtrim(npts,2)+')'
      return, !values.d_nan
  endif
  
  ;; Be sure NGRAN is a multiple of NPTS - or not.  Instead, a warning
  ;; message is printed in the loop.
;  if abs(double(ngran)/npts - round(ngran/npts)) GT 1d-5 then begin
;      message, 'ERROR: NPOINTS must be a multiple of NGRANULE'
;      return, !values.d_nan
;  endif
  
  ;; Be sure we are solving a least-squares problem.  If the number of
  ;; polynomials is too great then it becomes underconstrained, not
  ;; overconstrained.
  if n_elements(dxdt) GT 0 then begin
      if npoly GE 2*(npts+1) then $
        message, 'ERROR: NPOLYNOMIAL must be less than 2*(NPOINTS+1)'
  endif else begin
      if npoly GE npts+1 then $
        message, 'ERROR: NPOLYNOMIAL must be less than NPOINTS+1'
  endelse
  
  ;; Begin size checking of input matrices - we may be able to use the
  ;; previously computed version.
  szx = size(xmatrix)
  szv = size(dxmatrix)

  ;; Cases: recompute because existing X matrix is wrong size;
  ;;        recompute because existing V matrix is wrong size;
  ;;        recompute because a V matrix was passed, but no DXDT was
  redo_x = (szx(0) NE 2 OR szx(1) NE npts+1 OR szx(2) NE npoly)
  redo_v = (n_elements(dxdt) GT 0 AND $
            (szv(0) NE 2 OR szv(1) NE npts+1 OR szv(2) NE npoly))
  no_v = (n_elements(dxdt) EQ 0 AND n_elements(dxmatrix) GT 0)

  ;; Actual recomputation of matrices
  if redo_x OR redo_v OR no_v OR keyword_set(reset) then begin
      COMPUTE_CHEBMAT:
      xmatrix = 0 & dummy = temporary(xmatrix)
      dxmatrix = 0 & dummy = temporary(dxmatrix)

      if n_elements(dxdt) GT 0 then $
        chebpcmat, npts+1, npoly, xmatrix, dxmatrix, dweight=dweight0 $
      else $
        chebpcmat_xonly, npts+1, npoly, xmatrix
  endif

  rms = 0.*x(0)
  drms = rms
  chebm = dblarr(npoly, (n_elements(x)-1)/ngran)
  resid = x*0.
  dresid = resid

  ispan = lindgen(npts+1)*(ngran/npts)
  imax = max(ispan)
  ng = 0L
  for ibase = 0, n_elements(x)-1, ngran do begin
      if ibase EQ n_elements(x)-1 then goto, DONE
      if n_elements(x)-ibase LT ngran+1 then begin
          nlost = n_elements(x)-ibase
          message, 'WARNING: last '+strtrim(nlost,2)+' elements of X '+$
            'were discarded because they formed only a fractional granule.', $
            /info
          goto, DONE
      endif

      tspan  = [t(ibase), t(ibase+imax)]
      tgran = t(ibase:ibase+imax-1)-t(ibase)
      dt     = tspan(1) - tspan(0)
      tspan  = tspan - tspan(0)

      ;; Compute the X portion of the coefficients
      xgran  = x(ibase+ispan)
      chebi  = xmatrix ## xgran

      ;; Compute the DXDT portion if it is available
      if n_elements(dxdt) GT 0 then begin
          dxgran = dxdt(ibase+ispan) * dt/2.
          chebi = chebi + dxmatrix ## dxgran

          ;; Statistics - V first, then X comes later
          xmod = chebeval(tgran, chebi, interval=tspan, derivative=dxmod)

          ;; DXDT portion of statistics
          dresid(ibase:ibase+imax-1) = dxdt(ibase:ibase+imax-1) -  dxmod
          diff_dx = (dxdt(ibase:ibase+imax-1) - dxmod)^2
          drms = drms + total(diff_dx)

      endif else begin
          ;; Statistics - X only

          xmod = chebeval(tgran, chebi, interval=tspan)
      endelse

      ;; Finish statistics with X portion
      resid(ibase:ibase+imax-1) = x(ibase:ibase+imax-1) -  xmod
      diff_x  = (   x(ibase:ibase+imax-1) -  xmod)^2
      rms  =  rms + total(diff_x)

      ;; Append to existing coefficient list
      chebm(*,ng) = chebi(*)
      ng = ng + 1L
  endfor
  
  DONE:
  ;; Final adjustments to statistics
  rms  = sqrt( rms / ngran)
  if n_elements(dxdt) GT 0 then drms = sqrt(drms / ngran)

  return, chebm
end
;+
; NAME:
;   CMAPPLY
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Applies a function to specified dimensions of an array
;
; MAJOR TOPICS:
;   Arrays
;
; CALLING SEQUENCE:
;   XX = CMAPPLY(OP, ARRAY, DIMS, [/DOUBLE], [TYPE=TYPE])
;
; DESCRIPTION:
;   CMAPPLY will apply one of a few select functions to specified 
;   dimensions of an array.  Unlike some IDL functions, you *do* have
;   a choice of which dimensions that are to be "collapsed" by this
;   function.  Iterative loops are avoided where possible, for 
;   performance reasons.
;
;   The possible functions are:             (and number of loop iterations:)
;     +     - Performs a sum (as in TOTAL)       number of collapsed dimensions
;     AND   - Finds LOGICAL "AND" (not bitwise)  same
;     OR    - Finds LOGICAL "OR"  (not bitwise)  same
;     *     - Performs a product                 LOG_2[no. of collapsed elts.]
;
;     MIN   - Finds the minimum value            number of collapsed dimensions
;     MAX   - Finds the maximum value            same
;     MEDIAN- Finds the median  value            same
;
;     USER  - Applies user-defined function      no. of output elements
;
;
;   It is possible to perform user-defined operations arrays using
;   CMAPPLY.  The OP parameter is set to 'USER:FUNCTNAME', where
;   FUNCTNAME is the name of a user-defined function.  The user
;   defined function should be defined such that it accepts a single
;   parameter, a vector, and returns a single scalar value.  Here is a
;   prototype for the function definition:
;
;      FUNCTION FUNCTNAME, x, KEYWORD1=key1, ...
;         scalar = ... function of x or keywords ...
;         RETURN, scalar
;      END
;
;   The function may accept keywords.  Keyword values are passed in to
;   CMAPPLY through the FUNCTARGS keywords parameter, and passed to
;   the user function via the _EXTRA mechanism.  Thus, while the
;   definition of the user function is highly constrained in the
;   number of positional parameters, there is absolute freedom in
;   passing keyword parameters.
;
;   It's worth noting however, that the implementation of user-defined
;   functions is not particularly optimized for speed.  Users are
;   encouraged to implement their own array if the number of output
;   elements is large.
;
;
; INPUTS:
;
;   OP - The operation to perform, as a string.  May be upper or lower
;        case.
;
;        If a user-defined operation is to be passed, then OP is of
;        the form, 'USER:FUNCTNAME', where FUNCTNAME is the name of
;        the user-defined function.
;
;   ARRAY - An array of values to be operated on.  Must not be of type
;           STRING (7) or STRUCTURE (8).
;
; OPTIONAL INPUTS:
;
;   DIMS - An array of dimensions that are to be "collapsed", where
;          the the first dimension starts with 1 (ie, same convention
;          as IDL function TOTAL).  Whereas TOTAL only allows one
;          dimension to be added, you can specify multiple dimensions
;          to CMAPPLY.  Order does not matter, since all operations
;          are associative and transitive.  NOTE: the dimensions refer
;          to the *input* array, not the output array.  IDL allows a 
;          maximum of 8 dimensions.
;          DEFAULT: 1 (ie, first dimension)
;
; KEYWORDS:
;
;   DOUBLE - Set this if you wish the internal computations to be done
;            in double precision if necessary.  If ARRAY is double 
;            precision (real or complex) then DOUBLE=1 is implied.
;            DEFAULT: not set
;
;   TYPE - Set this to the IDL code of the desired output type (refer
;          to documentation of SIZE()).  Internal results will be
;          rounded to the nearest integer if the output type is an
;          integer type.
;          DEFAULT: same is input type
;
;   FUNCTARGS - If OP is 'USER:...', then the contents of this keyword
;               are passed to the user function using the _EXTRA
;               mechanism.  This way you can pass additional data to
;               your user-supplied function, via keywords, without
;               using common blocks.
;               DEFAULT: undefined (i.e., no keywords passed by _EXTRA)
;
; RETURN VALUE:
;
;   An array of the required TYPE, whose elements are the result of
;   the requested operation.  Depending on the operation and number of
;   elements in the input array, the result may be vulnerable to
;   overflow or underflow.
;
; EXAMPLES:
;   Shows how CMAPPLY can be used to total the second dimension of the
;   array called IN.  This is equivalent to OUT = TOTAL(IN, 2)
;
;   IDL> IN  = INDGEN(5,5)
;   IDL> OUT = CMAPPLY('+', IN, [2])
;   IDL> HELP, OUT
;   OUT             INT       = Array[5]
;
;   Second example.  Input is assumed to be an 5x100 array of 1's and
;   0's indicating the status of 5 detectors at 100 points in time.
;   The desired output is an array of 100 values, indicating whether
;   all 5 detectors are on (=1) at one time.  Use the logical AND
;   operation.
;
;   IDL> IN = detector_status             ; 5x100 array
;   IDL> OUT = CMAPPLY('AND', IN, [1])    ; collapses 1st dimension
;   IDL> HELP, OUT
;   OUT             BYTE      = Array[100]
;
;   (note that MIN could also have been used in this particular case,
;   although there would have been more loop iterations).
;
;   Third example.  Shows sum over first and third dimensions in an
;   array with dimensions 4x4x4:
;
;   IDL> IN = INDGEN(4,4,4)
;   IDL> OUT = CMAPPLY('+', IN, [1,3])
;   IDL> PRINT, OUT
;        408     472     536     600
;
;   Fourth example. A user-function (MEDIAN) is used:
;
;   IDL> IN = RANDOMN(SEED,10,10,5)
;   IDL> OUT = CMAPPLY('USER:MEDIAN', IN, 3)
;   IDL> HELP, OUT
;   OUT             FLOAT     = Array[10, 10]
;
;   (OUT(i,j) is the median value of IN(i,j,*))
;
; MODIFICATION HISTORY:
;   Mar 1998, Written, CM
;   Changed usage message to not bomb, 24 Mar 2000, CM
;   Signficant rewrite for *, MIN and MAX (inspired by Todd Clements
;     <Todd_Clements@alumni.hmc.edu>); FOR loop indices are now type
;     LONG; copying terms are liberalized, CM, 22, Aug 2000
;   More efficient MAX/MIN (inspired by Alex Schuster), CM, 25 Jan
;     2002
;   Make new MAX/MIN actually work with 3d arrays, CM, 08 Feb 2002
;   Add user-defined functions, ON_ERROR, CM, 09 Feb 2002
;   Correct bug in MAX/MIN initialization of RESULT, CM, 05 Dec 2002
;   Correct bug in CMAPPLY_PRODUCT implementation when there are an
;     odd number of values to combine, CM 26 Jul 2006
;   Add fast IDL versions of '*', 'MEDIAN', 'MIN' and 'MAX', where
;     IDL supports it, CM 26 Jul 2006
;
;  $Id: cmapply.pro,v 1.6 2006/07/26 19:34:24 craigm Exp $
;
;-
; Copyright (C) 1998, 2000, 2002, 2006, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Utility function, adapted from CMPRODUCT
function cmapply_product, x
  sz = size(x)
  n = sz(1)

  while n GT 1 do begin
      if (n mod 2) EQ 1 then x(0,*) = x(0,*) * x(n-1,*)
      n2 = floor(n/2)
      x = x(0:n2-1,*) * x(n2:n2*2-1,*)
      n = n2
  endwhile
  return, reform(x(0,*), /overwrite)
end

;; Utility function, used to collect collaped dimensions
pro cmapply_redim, newarr, dimapply, dimkeep, nkeep, totcol, totkeep
  sz = size(newarr)
  ;; First task: rearrange dimensions so that the dimensions
  ;; that are "kept" (ie, uncollapsed) are at the back
  dimkeep = where(histogram(dimapply,min=1,max=sz(0)) ne 1, nkeep)
  if nkeep EQ 0 then return

  newarr = transpose(temporary(newarr), [dimapply-1, dimkeep])
  ;; totcol is the total number of collapsed elements
  totcol = sz(dimapply(0))
  for i = 1, n_elements(dimapply)-1 do totcol = totcol * sz(dimapply(i))
  totkeep = sz(dimkeep(0)+1)
  for i = 1, n_elements(dimkeep)-1 do totkeep = totkeep * sz(dimkeep(i)+1)

  ;; this new array has two dimensions:
  ;;   * the first, all elements that will be collapsed
  ;;   * the second, all dimensions that will be preserved
  ;; (the ordering is so that all elements to be collapsed are
  ;;  adjacent in memory)
  newarr = reform(newarr, [totcol, totkeep], /overwrite)
end

;; Main function
function cmapply, op, array, dimapply, double=dbl, type=type, $
                  functargs=functargs, nocatch=nocatch

  if n_params() LT 2 then begin
      message, "USAGE: XX = CMAPPLY('OP',ARRAY,2)", /info
      message, '       where OP is +, *, AND, OR, MIN, MAX', /info
      return, -1L
  endif
  if NOT keyword_set(nocatch) then $
    on_error, 2 $
  else $
    on_error, 0

  version = double(!version.release)
;  version = 0
;  print, 'version = ',version

  ;; Parameter checking
  ;; 1) the dimensions of the array
  sz = size(array)
  if sz(0) EQ 0 then $
    message, 'ERROR: ARRAY must be an array!'

  ;; 2) The type of the array
  if sz(sz(0)+1) EQ 0 OR sz(sz(0)+1) EQ 7 OR sz(sz(0)+1) EQ 8 then $
    message, 'ERROR: Cannot apply to UNDEFINED, STRING, or STRUCTURE'
  if n_elements(type) EQ 0 then type = sz(sz(0)+1)

  ;; 3) The type of the operation
  szop = size(op)
  if szop(szop(0)+1) NE 7 then $
    message, 'ERROR: operation OP was not a string'

  ;; 4) The dimensions to apply (default is to apply to first dim)
  if n_params() EQ 2 then dimapply = 1
  dimapply = [ dimapply ]
  dimapply = dimapply(sort(dimapply))   ; Sort in ascending order
  napply = n_elements(dimapply)

  ;; 5) Use double precision if requested or if needed
  if n_elements(dbl) EQ 0 then begin
      dbl=0
      if type EQ 5 OR type EQ 9 then dbl=1
  endif

  newop = strupcase(op)
  newarr = array
  newarr = reform(newarr, sz(1:sz(0)), /overwrite)
  case 1 of

      ;; *** Addition
      (newop EQ '+'): begin
          for i = 0L, napply-1 do begin
              newarr = total(temporary(newarr), dimapply(i)-i, double=dbl)
          endfor
      end

      ;; *** Multiplication
      (newop EQ '*'): begin ;; Multiplication (by summation of logarithms)
          forward_function product

          cmapply_redim, newarr, dimapply, dimkeep, nkeep, totcol, totkeep
          if nkeep EQ 0 then begin
              newarr = reform(newarr, n_elements(newarr), 1, /overwrite)
              if version GT 5.55 then return, product(newarr)
              return, (cmapply_product(newarr))(0)
          endif

          if version GT 5.55 then begin
              result = product(newarr,1)
          endif else begin
              result = cmapply_product(newarr)
          endelse
          result = reform(result, sz(dimkeep+1), /overwrite)
          return, result
      end

      ;; *** LOGICAL AND or OR
      ((newop EQ 'AND') OR (newop EQ 'OR')): begin
          newarr = temporary(newarr) NE 0
          totelt = 1L
          for i = 0L, napply-1 do begin
              newarr = total(temporary(newarr), dimapply(i)-i)
              totelt = totelt * sz(dimapply(i))
          endfor
          if newop EQ 'AND' then return, (round(newarr) EQ totelt)
          if newop EQ 'OR'  then return, (round(newarr) NE 0)
      end

      ;; Operations requiring a little more attention over how to
      ;; iterate
      ((newop EQ 'MAX') OR (newop EQ 'MIN') OR (newop EQ 'MEDIAN')): begin
          cmapply_redim, newarr, dimapply, dimkeep, nkeep, totcol, totkeep
          if nkeep EQ 0 then begin
              if newop EQ 'MAX' then return, max(newarr)
              if newop EQ 'MIN' then return, min(newarr)
              if newop EQ 'MEDIAN' then return, median(newarr)
          endif

          ;; IDL 5.5 introduced the DIMENSION keyword to MAX() and MIN()
          if version GT 5.45 then begin
              extra = {dimension:1}
              if newop EQ 'MAX' then result = max(newarr, _EXTRA=extra)
              if newop EQ 'MIN' then result = min(newarr, _EXTRA=extra)
              if newop EQ 'MEDIAN' then result = median(newarr, _EXTRA=extra)
          endif else begin
              
              ;; Next task: create result array
              result = make_array(totkeep, type=type)
              
              ;; Now either iterate over the number of output elements, or
              ;; the number of collapsed elements, whichever is smaller.
              if (totcol LT totkeep) AND newop NE 'MEDIAN' then begin
                  ;; Iterate over the number of collapsed elements
                  result(0) = reform(newarr(0,*),totkeep,/overwrite)
                  case newop of 
                      'MAX': for i = 1L, totcol-1 do $
                        result(0) = result > newarr(i,*)
                      'MIN': for i = 1L, totcol-1 do $
                        result(0) = result < newarr(i,*)
                  endcase
              endif else begin
                  ;; Iterate over the number of output elements
                  case newop of 
                      'MAX': for i = 0L, totkeep-1 do result(i) = max(newarr(*,i))
                      'MIN': for i = 0L, totkeep-1 do result(i) = min(newarr(*,i))
                      'MEDIAN': for i = 0L, totkeep-1 do result(i) = median(newarr(*,i))
                  endcase
              endelse
          endelse

          result = reform(result, sz(dimkeep+1), /overwrite)
          return, result
      end

      ;; User function
      (strmid(newop,0,4) EQ 'USER'): begin
          functname = strmid(newop,5)
          if functname EQ '' then $
            message, 'ERROR: '+newop+' is not a valid operation'

          cmapply_redim, newarr, dimapply, dimkeep, nkeep, totcol, totkeep
          if nkeep EQ 0 then begin
              if n_elements(functargs) GT 0 then $
                return, call_function(functname, newarr, _EXTRA=functargs)
              return, call_function(functname, newarr)
          endif
          
          ;; Next task: create result array
          result = make_array(totkeep, type=type)
          
          ;; Iterate over the number of output elements
          if n_elements(functargs) GT 0 then begin
              for i = 0L, totkeep-1 do $
                result(i) = call_function(functname, newarr(*,i), _EXTRA=functargs)
          endif else begin
              for i = 0L, totkeep-1 do $
                result(i) = call_function(functname, newarr(*,i))
          endelse

          result = reform(result, sz(dimkeep+1), /overwrite)
          return, result
      end

              
  endcase

  newsz = size(newarr)
  if type EQ newsz(newsz(0)+1) then return, newarr

  ;; Cast the result into the desired type, if necessary
  castfns = ['UNDEF', 'BYTE', 'FIX', 'LONG', 'FLOAT', $
             'DOUBLE', 'COMPLEX', 'UNDEF', 'UNDEF', 'DCOMPLEX' ]
  if type GE 1 AND type LE 3 then $
    return, call_function(castfns(type), round(newarr)) $
  else $
    return, call_function(castfns(type), newarr)
end
  
;+
; NAME:
;   ARG_PRESENT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Determine whether output parameter has been passed (IDL4 compatibility)
;
; CALLING SEQUENCE:
;   PRESENT = ARG_PRESENT(ARG)
;
; DESCRIPTION: 
;
;   ARG_PRESENT tests whether an argument to a function or procedure
;   can be used as an output parameter.  The behavior of this function
;   is identical to that of the built-in ARG_PRESENT function in IDL
;   version 5 or greater, and is meant to give the same functionality
;   to programs in IDL 4.
;
;   An IDL procedure or function can use ARG_PRESENT to decide whether
;   the value of a positional or keyword parameter will be returned to
;   the calling procedure.  Generally, if the caller did not pass the
;   parameter then there is no need to compute the value to be
;   returned.
;
;   To be a valid output parameter, the caller must have passed a
;   named variable into which the result is stored.  If the caller
;   passed the parameter by value (e.g., an expression or a
;   subscripted array) the value cannot be returned and ARG_PRESENT
;   returns 0.
;
; INPUTS:
;
;   ARG - the parameter to be tested.  It can be either a positional
;         or a keyword parameter.  Passing a normal local variable
;         (i.e., not a passed parameter) will cause ARG_PRESENT to
;         return zero.
;
; RETURNS:
;
;   Returns a value of 1 if ARG is a valid output parameter, and a
;   value of 0 otherwise.
;
;
; EXAMPLE:
;
;   Consider the following procedure:
;      PRO TESTARG, ARG1
;        print, ARG_PRESENT(ARG1)
;      END
;
;   This procedure will print 1 when an ARG1 can be used as an output
;   parameter.  Here are some examples of the results of TESTARG.
;
;      IDL> testarg
;             0
;      IDL> testarg, x      
;             1
;      IDL> testarg, findgen(10)
;             0
;   
;   In the first case, no argument is passed, so ARG1 cannot be a
;   return variable.  In the second case, X is undefined, but it is
;   still a legal named variable capable of receiving an output
;   parameter.  In the third case, FINDGEN(10) is an expression which
;   cannot receive an output parameter.
;
; SEE ALSO:
;
;   ARG_PRESENT in IDL version 5
;
; MODIFICATION HISTORY:
;   Written, CM, 13 May 2000
;   Small documentation and bug fixes, CM, 04 Jul 2000
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; $Id: cmcongrid.pro,v 1.3 2007/03/29 13:52:20 craigm Exp $

;+
; NAME:
;	CMCONGRID
;
; PURPOSE:
;       Shrink or expand the size of an array by an arbitrary amount.
;       This IDL procedure simulates the action of the VAX/VMS
;       CONGRID/CONGRIDI function.
;
;	This function is similar to "REBIN" in that it can resize a
;       one, two, or three dimensional array.   "REBIN", however,
;       requires that the new array size must be an integer multiple
;       of the original size.   CONGRID will resize an array to any
;       arbitrary size (REBIN is somewhat faster, however).
;       REBIN averages multiple points when shrinking an array,
;       while CONGRID just resamples the array.
;
; CATEGORY:
;       Array Manipulation.
;
; CALLING SEQUENCE:
;	array = CONGRID(array, x, y, z)
;
; INPUTS:
;       array:  A 1, 2, or 3 dimensional array to resize.
;               Data Type : Any type except string or structure.
;
;       x:      The new X dimension of the resized array.
;               Data Type : Int or Long (greater than or equal to 2).
;
; OPTIONAL INPUTS:
;       y:      The new Y dimension of the resized array.   If the original
;               array has only 1 dimension then y is ignored.   If the
;               original array has 2 or 3 dimensions then y MUST be present.
;
;       z:      The new Z dimension of the resized array.   If the original
;               array has only 1 or 2 dimensions then z is ignored.   If the
;               original array has 3 dimensions then z MUST be present.
;
; KEYWORD PARAMETERS:
;       INTERP: If set, causes linear interpolation to be used.
;               Otherwise, the nearest-neighbor method is used.
;
;	CUBIC:	If set, uses "Cubic convolution" interpolation.  A more
;		accurate, but more time-consuming, form of interpolation.
;		CUBIC has no effect when used with 3 dimensional arrays.
;
;       MINUS_ONE:
;               If set, will prevent CONGRID from extrapolating one row or
;               column beyond the bounds of the input array.   For example,
;               If the input array has the dimensions (i, j) and the
;               output array has the dimensions (x, y), then by
;               default the array is resampled by a factor of (i/x)
;               in the X direction and (j/y) in the Y direction.
;               If MINUS_ONE is present (AND IS NON-ZERO) then the array
;               will be resampled by the factors (i-1)/(x-1) and
;               (j-1)/(y-1).
;
;       HALF_HALF:
;               If set, will tell CONGRID to extrapolate a *half* row
;               and column on either side, rather than the default of
;               one full row/column at the ends of the array.  If you
;               are interpolating images with few rows, then the
;               output will be more consistent with this technique.
;               This keyword is intended as a replacement for
;               MINUS_ONE, and both keywords probably should not be
;               used in the same call to CONGRID.
;
; OUTPUTS:
;	The returned array has the same number of dimensions as the original
;       array and is of the same data type.   The returned array will have
;       the dimensions (x), (x, y), or (x, y, z) depending on how many
;       dimensions the input array had.
;
; PROCEDURE:
;       IF the input array has three dimensions, or if INTERP is set,
;       then the IDL interpolate function is used to interpolate the
;       data values.
;       If the input array has two dimensions, and INTERP is NOT set,
;       then the IDL POLY_2D function is used for nearest neighbor sampling.
;       If the input array has one dimension, and INTERP is NOT set,
;       then nearest neighbor sampling is used.
;
; EXAMPLE:
;       ; vol is a 3-D array with the dimensions (80, 100, 57)
;       ; Resize vol to be a (90, 90, 80) array
;       vol = CONGRID(vol, 90, 90, 80)
;
; MODIFICATION HISTORY:
;       DMS, Sept. 1988.
;       DMS, Added the MINUS_ONE keyword, Sept. 1992.
; 	Daniel Carr. Re-wrote to handle one and three dimensional arrays
;                    using INTERPOLATE function.
; 	DMS, RSI, Nov, 1993.  Added CUBIC keyword.
;       Craig Markwardt, Dec, 1997.  Added halfhalf keyword to
;                        more evenly distribute "dead" pixel row
;       Use uniformly spaced grid points for half_half W. Landsman   Feb. 2000
;              (and slightly modified by C. Markwardt 14 Feb 2000)
;       Fix in case where INTERP=0 (nearest neighbor interp) and
;         expanding the image (thanks to Larry Bradley) 28 Mar 2007
;
;  $Id: cmcongrid.pro,v 1.3 2007/03/29 13:52:20 craigm Exp $
;-
;  Supply defaults = no interpolate, and no minus_one.
if n_elements(int) le 0 then int = 0 else int = keyword_set(int)
if n_elements(m1) le 0 then m1 = 0 else m1 = keyword_set(m1)

; Compute offsets pixel offsets for half_half
halfx = 0.0 & halfy = 0.0 & halfz = 0.0
if keyword_set(hh) then begin
    if s(0) GE 1 then halfx = -0.5 + (float(s(1))/x)
    if s(0) GE 2 then halfy = -0.5 + (float(s(2))/y)
    if s(0) GE 3 then halfz = -0.5 + (float(s(3))/z)
endif
cub = KEYWORD_SET(cubic)
if cub THEN int = 1	;Cubic implies interpolate
	

CASE s(0) OF
   1: BEGIN				; *** ONE DIMENSIONAL ARRAY
	srx = float(s(1) - m1)/(x-m1) * findgen(x) + halfx
      IF int THEN $
         RETURN, INTERPOLATE(arr, srx, CUBIC = cub) ELSE $
         RETURN, arr(ROUND(srx))
   ENDCASE
   2: BEGIN ; *** TWO DIMENSIONAL ARRAY
	IF int THEN BEGIN
	  srx = float(s(1) - m1) / (x-m1) * findgen(x) + halfx
	  sry = float(s(2) - m1) / (y-m1) * findgen(y) + halfy
          RETURN, INTERPOLATE(arr, srx, sry, /GRID, CUBIC=cub)
	ENDIF ELSE BEGIN
          ;; match IDL's CONGRID function
          expand = (x gt s[1])
          xm1 = (m1 or expand) ? x-1 : x
          RETURN, POLY_2D(arr, $
               [[0,0],[(s(1)-m1)/float(xm1),0]], $ ;Use poly_2d
               [[0,(s(2)-m1)/float(y-m1)],[0,0]],int,x,y)
        ENDELSE

   ENDCASE
   3: BEGIN ; *** THREE DIMENSIONAL ARRAY
	srx = float(s(1) - m1) / (x-m1) * findgen(x) + halfx
	sry = float(s(2) - m1) / (y-m1) * findgen(y) + halfy
	srz = float(s(3) - m1) / (z-m1) * findgen(z) + halfz
	RETURN, interpolate(arr, srx, sry, srz, /grid)
   ENDCASE
ENDCASE

RETURN, arr_r
END
;+
; NAME:
;   CMPRODUCT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   CMPRODUCT() is the multiplicative equivalent of TOTAL().
;
; CALLING SEQUENCE:
;   Result = CMPRODUCT(ARRAY)
;
; DESCRIPTION: 
;
;   Calculates the product of all the elements of an array.  Vector
;   multiplication in groups of powers of two make this operation
;   faster than a simple FOR loop.  The number of actual
;   multiplications is still N_ELEMENTS(ARRAY).  Double precision
;   should be used for the highest accuracy when multiplying many
;   numbers.
;
; INPUTS:
;
;   ARRAY - Array of elements to multiply together.  For instance,
;           ARRAY could contain the dimensions of another array--then
;           CMPRODUCT(ARRAY) would be the total number of elements of
;           that other array.
;
; RETURNS:
;  The result of the function is the total product of all the elements
;  of ARRAY.
;
; EXAMPLE:
;
; SEE ALSO:
;
;   TOTAL, PRODUCT (from Astronomy User's Library)
;
; MODIFICATION HISTORY:
;   Written, CM, 28 Mar 2000
;     (based on outline of PRODUCT by William Thompson)
;
;  $Id: cmproduct.pro,v 1.2 2001/03/25 18:10:42 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;
;  Check the number of parameters.
;
  IF N_PARAMS() NE 1 THEN MESSAGE,'Syntax:  Result = PRODUCT(ARRAY)'
;
;  Check the type of ARRAY.
;
  SZ = SIZE(ARRAY)
  TYPE = SZ(SZ(0)+1)
  IF TYPE EQ 0 THEN MESSAGE,'ARRAY not defined'
  IF TYPE EQ 7 THEN MESSAGE,'Operation illegal with string arrays'
  IF TYPE EQ 8 THEN MESSAGE,'Operation illegal with structures'
;
;  Calculate the product.
;
  X = ARRAY
  N = N_ELEMENTS(X)
  WHILE N GT 1 DO BEGIN
      IF (N MOD 2) EQ 1 THEN X(0) = X(0) * X(N-1)
      N2 = FLOOR(N/2)
      X = X(0:N2-1) * X(N2:*)
      N = N2
  ENDWHILE
;
  RETURN,X(0)
END
;+
; NAME:
;   CMPS_FORM
;
; PURPOSE:
;   This function puts up a form the user can configure a PostScript
;   device driver. The function result (if the user selects either the
;   ACCEPT or CREATE FILE buttons) can be sent directly to the DEVICE
;   procedure by means of its _Extra keyword.  User's predefined
;   configurations may be retrieved from a common block.
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   $Id: cmps_form.pro,v 1.5 2004/10/03 09:40:08 craigm Exp $
;
;   Based almost entirely on, but a totally revamped version of, CMPS_FORM by 
;   FANNING SOFTWARE CONSULTING (David Fanning Ph.D.) http://www.dfanning.com
;
; MAJOR TOPICS:
;   Device Drivers, Hardcopy Output, PostScript Output
;
; PROCEDURE:
;   This is a pop-up form widget. It is a modal or blocking widget.
;   Keywords appropriate for the PostScript DEVICE command are returned.
;
;   Use your LEFT mouse button to move the "Plot Window" around the page.
;   Use your RIGHT mouse button to draw your own "Plot Window" on the page.
;
; HELP:
;   formInfo = CMPS_FORM(/Help)
;
; CALLING SEQUENCE:
;    formInfo = CMPS_FORM(xoffset, yoffset, Cancel=cancelButton)
;
; OPTIONAL INPUTS:
;
;    XOFFSET -- Optional xoffset of the top-level base of cmps_form. Default is
;    to try to center the form on the display.
;
;    YOFFSET -- Optional yoffset of the top-level base of cmps_form. Default is
;    to try to center the form on the display.
;
; INPUT KEYWORD PARAMETERS:
;
;    BITS_PER_PIXEL -- The initial configuration of the bits per pixel button.
;
;    BLOCKING -- Set this keyword to make this a blocking widget under IDL 5.0.
;    (All widget programs block under IDL 4.0.)
;
;    COLOR -- The initial configuration of the color switch.
;
;    DEFAULTS -- A stucture variable of the same type and structure as the
;    RETURN VALUE of cmps_form. It will set initial conditions. This makes
;    it possible to start cmps_form up again with the same values it had the
;    last time it was called. For example:
;
;       mysetup = cmps_form()
;       newsetup = cmps_form(Defaults=mysetup)
;
;    ENCAPSULATED -- The initial configuration of the encapsulated switch.
;
;    FILENAME -- The initial filename to be used on the form.
;
;    HELP -- Prints a helpful message in the output log.
;
;    INCHES -- The initial configuration of the inches/cm switch.
;
;    INITIALIZE -- If this keyword is set, the program immediately returns the
;    "localdefaults" structure. This gives you the means to configue the
;    PostScript device without interrupting the user.
;
;    SELECT -- used only when INITIALIZE is set.  Set SELECT to a
;              string which identifies the predefined configuration to
;              be returned by cmps_form when INITIALIZE is set.  This is
;              a convenient way to select a predefined config
;              non-interactively.
;
;    LANDSCAPE -- The initial configuration of the landscape/portrait switch.
;
;    LOCALDEFAULTS -- A structure like the DEFAULTS structure. If specified,
;    then it is added as a predefined configuration entry called "Local".
;    See below for a further discussion of predefined configurations.
;
;    PREDEFINED -- An alternate way to specify predefined
;                  configurations.  Pass an array of structures to
;                  populate the "predefined" dropbox in the
;                  dialog. This array, if specified, overrides the the
;                  common block technique.
;
;    XOFFSET -- The initial XOffSet of the PostScript window.
;
;    YOFFSET -- The initial YOffSet of the PostScript window.
;
;    XSIZE -- The initial XSize of the PostScript window.
;
;    YSIZE -- The initial YSize of the PostScript window.
;
;    ASPECT -- The aspect ratio of the window (Y/X).  This keyword can
;              substitute for one of XSIZE or YSIZE.
; 
;    PRESERVE_ASPECT -- Set this keyword if you want to hold the
;                       aspect ratio constant.
;
;    PAPERSIZE -- If set, allows user to specify the size of the paper
;                 media to be printed on, as a scalar string.  NOTE:
;                 this specification cannot be passed to DEVICE, but
;                 can be selected for completeness's sake.  Default is
;                 'Letter'.
;
;    MARGINSIZE -- Size of the margins on all sides.  Default is 0.25 inches.
;                  When MARGINSIZE is non-zero, a graphic cannot directly
;                  abut the edge of the page.  This is normally a good thing,
;                  since there is often a  non-printable region which borders
;                  the page.
;
;   DEFAULTPAPER -- Default paper size to use, when it is unspecified
;                   in a predefined, "local", or "default"
;                   configuration.  This value also overrides any
;                   configuration from common blocks.  European users
;                   will probably set this to 'A4'.
;
;   PARENT -- if this widget is invoked by another widget program,
;             then this keyword parameter must be set to the top level
;             widget which is to serve as the group leader.  Failure
;             to do so will result in unexpected behavior.  IDL 4
;             programs do not need to pass this parameter.  Default:
;             NONE.
;
; OUTPUT KEYWORD PARAMETERS
;
;    CANCEL -- This is an OUTPUT keyword. It is used to check if the user
;    selected the "Cancel" button on the form. Check this variable rather
;    than the return value of the function, since the return value is designed
;    to be sent directly to the DEVICE procedure. The varible is set to 1 if
;    the user selected the "Cancel" button. Otherwise, it is set to 0.
;
;    CREATE -- This output keyword can be used to determine if the user
;    selected the 'Create File' button rather than the 'Accept' button.
;    The value is 1 if selected, and 0 otherwise.
;
;    PAPERSIZE -- If set to a named variable, any newly selected paper
;    size is returned in that variable.
;
;    XPAGESIZE -- Size of paper in "X" dimension, in units given by
;                 the returned config structure.
;
;    YPAGESIZE -- Size of paper in "Y" dimension, in units given by
;                 the returned config structure.
;
;    PAGEBOX -- specifies the page rectangle relative to the plot
;               window, in normalized units.  A 4-vector of the form
;               [XLL, YLL, XUR, YUR] is returned, giving the positions
;               of the lower left (LL) and upper right (UR) corners of
;               the page with respect to the plot window.  Thus, the
;               following command:
;
;                    PLOT, x, y, position=PAGEBOX
;
;               will construct a graphic whose plot region exactly
;               fills the page (with no margin around the edges).
;
;               Naturally, the page is usually larger than the
;               graphics window, so the normalized coordinates will
;               usually fall outside the range [0,1].
;
;               However, the bounding box constructed by the
;               Postscript driver includes only the graphics window.
;               Anything drawn outside of it may be clipped or
;               discarded.
;
; RETURN VALUE:
;
;     formInfo = { cmps_form_INFO, $
;                  xsize:0.0, $        ; The x size of the plot
;                  xoff:0.0, $         ; The x offset of the plot
;                  ysize:0.0, $        ; The y size of the plot
;                  yoff:0.0 $          ; The y offset of the plot
;                  filename:'', $      ; The name of the output file
;                  inches:0 $          ; Inches or centimeters?
;                  color:0, $          ; Color on or off?
;                  bits_per_pixel:0, $ ; How many bits per image pixel?
;                  encapsulated:0,$    ; Encapsulated or regular PostScript?
;                  isolatin1:0,$       ; Encoded with ISOLATIN1?
;                  landscape:0 }       ; Landscape or portrait mode?
;
; USAGE:
;
;  The calling procedure for this function in a widget program will
;  look something like this:
;
;     info.ps_config = cmps_form(/Initialize)
;
;     formInfo = cmps_form(Cancel=canceled, Create=create, $
;                          Defaults=info.ps_config)
;
;     IF NOT canceled THEN BEGIN
;        IF create THEN BEGIN
;           thisDevice = !D.Name
;           Set_Plot, "PS"
;           Device, _Extra=formInfo
;
;           Enter Your Graphics Commands Here!
;
;           Device, /Close
;           Set_Plot, thisDevice
;           info.ps_config = formInfo
;        ENDIF ELSE
;           info.ps_config = formInfo
;     ENDIF
;
; MAJOR FUNCTIONS and PROCEDURES:
;
;   None. Designed to work originally in conjunction with XWindow, a
;   resizable graphics window.  [ NOTE: this modified version of
;   cmps_form, by Craig Markwardt, is incompatible with the original
;   version of XWINDOW. ]
;
; MODIFICATION HISTORY:
;
;   Based on cmps_form of : David Fanning, RSI, March 1995.
;   Major rewrite by: Craig Markwardt, October 1997.
;     - Drawing and updating of form and sample box are now modular
;     - Option of storing more than one predefined postscript configuration
;     - Selection of paper size by name
;     - Access to predfined configurations through (optional) common
;       block
;   Several additions, CM, April 1998  VERSION CM2.0
;     - better integration of paper sizes throughout program.
;       Predefined configurations now also know about paper.
;     - allow passing predefined configurations instead of using
;       common block
;     - addition of ISOLATIN selection, and streamlining of dialog
;       appearance
;   Fixed bug in INITIALIZE w.r.t. paper sizes, CM, Nov 1998
;   Added SELECT keyword, CM, 09 Dec 1998
;   Added Parent keyword to allow modal widgets in IDL 5, 19 Jan 1999
;   Added "Choose" button for filename selection, 19 Sep 1999
;   Added ability to program different button names, 19 Sep 1999
;   Added ASPECT and PRESERVE_ASPECT, based on work by Aaron Barth, 18
;     Oct 1999
;   Removed NOCOMMON documentation and logic, 19 Oct 1999, CM
;   Added aspect to cmps_form_numevents (per Aaron Barth), 18 Oct 1999
;   Corrected small bug under Initialize keyword (inches), 18 Oct 1999
;   Made call to *_pscoord more consistent, 18 Oct 1999
;   Added XPAGESIZE, YPAGESIZE and PAGEBOX keywords, 19 Oct 1999
;   Small cosmetic cleanup, CM, 01 Feb 2000
;   Fix for IDL 5.5's handling of structures with arrays, CM, 11 Dec 2001
;   Replaced obsolete PICKFILE call with DIALOG_PICKFILE, Jeff Guerber,
;     24 Sep 2004
;   Transfer DEFAULTS and LOCALDEFAULTS values via STRUCT_ASSIGN,/NOZERO
;     instead of EXECUTE, Jeff Guerber, 24 Sep 2004.
;   Set CANCELBUTTON and CREATEBUTTON immediately on entry, so they're
;     defined even if user kills the window, Jeff Guerber, 24 Sep 2004.
;
; COMMON BLOCKS:
; 
;   The user may store frequently used or helpful configurations in a 
;   common block, and cmps_form() will attempt to access them.  This
;   provides a way for the user to have persistent, named,
;   configurations.
;
;   NOTE: this format has changed since the last version.  You may
;   have to quit your IDL session for the changes to take effect
;   properly.  If you have place a predefined configuration in your
;   startup file, you should review the new format.
;   
;     COMMON CMPS_FORM_CONFIGS, cmps_form_DEFAULT_PAPERSIZE, $
;                               cmps_form_STDCONFIGS
;
;        cmps_form_DEFAULT_PAPERSIZE - a string designating the default
;                                    paper size, when none is given.
;                                    The predefined configurations
;                                    offerred by this program will
;                                    respect the default value.  (See
;                                    also the DEFAULTPAPER keyword.)
;
;        cmps_form_STDCONFIGS - An array of cmps_form_CONFIG structures,
;                             each containing information about one
;                             predefined configuration, such as its
;                             name and size of paper.  Each "config"
;                             element is a cmps_form_INFO structure,
;                             which contains the actual postscript
;                             configuration.
;
;   See the IDL source code cmps_form_LOAD_CONFIGS for an example of how
;   to make a list of configurations.  One possibility would be to
;   declare and populate the common block from within the user's
;   start-up script, allowing the same configurations to appear in
;   every session.
;
;   cmps_form() takes its initial list of configurations from this
;   common block if it exists.  A default list is provided ala the
;   procedure cmps_form_LOAD_CONFIGS.  Any modifications that take place
;   during the cmps_form() widget session are not transferred back to
;   the common block upon return.  It might be useful to be able to do
;   this, through some form of 'save' procedure.
;
;   Also, if the PREDEFINED keyword is used, then the common block is
;   not consulted.
;
;  $Id: cmps_form.pro,v 1.5 2004/10/03 09:40:08 craigm Exp $
;
;-
; Copyright (C) 1996-1997, David Fanning
; Copyright (C) 1997-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; ***************************************************************
; Utility routines

forward_function filepath

; Convert from inches and centimeters to WIDGET_DRAW pixels 
pro cmps_form_Draw_Coords, drawpixperunit, xoff, yoff, xsize, ysize

  if n_elements(xoff) GT 0 then xoff   = xoff  * drawpixperunit + 1
  if n_elements(yoff) GT 0 then yoff   = yoff  * drawpixperunit + 1
  if n_elements(xsize) GT 0 then xsize = xsize * drawpixperunit
  if n_elements(ysize) GT 0 then ysize = ysize * drawpixperunit

  return
end

; Perform the opposite conversion of cmps_form_DRAW_COORDS
pro cmps_form_Real_Coords, drawpixperunit, xoff, yoff, xsize, ysize

  if n_elements(xoff) GT 0 then xoff   = (xoff-1) / drawpixperunit
  if n_elements(yoff) GT 0 then yoff   = (yoff-1) / drawpixperunit
  if n_elements(xsize) GT 0 then xsize = xsize / drawpixperunit
  if n_elements(ysize) GT 0 then ysize = ysize / drawpixperunit

  return
end

Pro cmps_form_Select_File, event

   ; Allows the user to select a filename for writing.

Widget_Control, event.top, Get_UValue=info, /No_Copy

   ; Start with the name in the filename widget.

Widget_Control, info.idfilename, Get_Value=initialFilename
initialFilename = initialFilename(0)
filename = Dialog_Pickfile(/Write, File=initialFilename)
IF filename NE '' THEN $
   Widget_Control, info.idfilename, Set_Value=filename
Widget_Control, event.top, Set_UValue=info, /No_Copy
END ;*******************************************************************

; Calculate a list of vertices to be plotted as a box in the 
; draw widget.
Function cmps_form_PlotBox_Coords, xsize, ysize, xoff, yoff, drawpixperunit

   ; This function converts sizes and offsets to appropriate
   ; Device coordinates for drawing the PLOT BOX on the PostScript
   ; page. The return value is a [2,5] array.

returnValue = IntArr(2,5)
xs = xsize
ys = ysize
xof = xoff
yof = yoff
cmps_form_draw_coords, drawpixperunit, xof, yof, xs, ys

; Add one because we do for the page outline
xcoords = Round([xof, xof+xs, xof+xs, xof, xof]) + 1
ycoords = Round([yof, yof, yof+ys, yof+ys, yof]) + 1

returnValue(0,*) = xcoords
returnValue(1,*) = ycoords

RETURN, returnValue
END ;*******************************************************************

; Convert between the IDL-form of PS coordinates (including the 
; strange definition of YOFFSET and XOFFSET) to a more
; "human-readable" form where the Xoffset and YOFFSET always refer to
; the lower-left hand corner of the output
pro cmps_form_conv_pscoord, info, xpagesize, ypagesize, $
      toidl=toidl, tohuman=tohuman

  if info.landscape EQ 1 then begin
      ixoff=info.xoff 
      iyoff=info.yoff
      if keyword_set(tohuman) then begin
          info.yoff = ixoff
          info.xoff = xpagesize - iyoff
      endif else if keyword_set(toidl) then begin
          info.xoff = iyoff
          info.yoff = xpagesize - ixoff
      endif
  endif
  return
end

; Return names of paper sizes
function cmps_form_papernames

  return, ['Letter','Legal','Tabloid','Ledger','Executive','Monarch', $
            'Statement','Folio','Quarto','C5','B4','B5','Dl','A0','A1', $
            'A2','A3','A4','A5','A6']
end

; Select a paper size based on number or string.  Returns x and 
; y page sizes, accouting for the units of measurement and the
; orientation of the page.
pro cmps_form_select_papersize, papertype, xpagesize, ypagesize, $
      inches=inches, landscape=landscape, index=index

;           Letter Legal Tabloid Ledger Executive Monarch Statement Folio
  xpaper = [612.,  612,  792,    792,   540,      279,    396,      612, $
$;          Quarto C5  B4  B5  Dl  A0   A1   A2   A3  A4  A5  A6
	    610,   459,729,516,312,2380,1684,1190,842,595,420,297]

;           Letter Legal Tabloid Ledger Executive Monarch Statement Folio
  ypaper = [792.,  1008, 1224,   1224,  720,      540,    612,      936, $
$;          Quarto C5  B4   B5  Dl  A0   A1   A2   A3   A4  A5  A6
	    780,   649,1032,729,624,3368,2380,1684,1190,842,595,421]
  names  = cmps_form_papernames()

  sz = size(papertype)
  tp = sz(sz(0) + 1)
  if tp GT 0 AND tp LT 6 then begin
      index = fix(papertype)
  endif else if tp EQ 7 then begin
      index = where(strupcase(papertype) EQ strupcase(names), ict)
      if ict EQ 0 then index = 0
  endif else $
    index = 0

  index = index(0)

  xpagesize = xpaper(index) / 72.  ; Convert to inches
  ypagesize = ypaper(index) / 72.
  xpagesize = xpagesize(0)
  ypagesize = ypagesize(0)
  if NOT keyword_set(inches) then begin
      xpagesize = xpagesize * 2.54
      ypagesize = ypagesize * 2.54
  endif
  if keyword_set(landscape) then begin
      temp = xpagesize
      xpagesize = ypagesize
      ypagesize = temp
  endif
  
  return
end

; cmps_form_LOAD_CONFIGS
;
; Loads a set of default configurations into the output variables,
;
;   CONFIGNAMES - array of names for configurations.
;
;   CONFIGS - array of cmps_form_INFO structures, each with a separate
;             configuration in it, and corresponding to the
;             configuration name.
;
; Intended as an intelligent default when no other is specified.
;
pro cmps_form_load_configs, defaultpaper, configs

  ; This is the default paper size, when none is given
  defaultpaper = 'Letter'

  ; Here is how the cmps_form_INFO structure is defined.  Refer to it
  ; when creating new structures.
  template = { cmps_form_INFO, $
               xsize:0.0, $     ; The x size of the plot
               xoff:0.0, $      ; The x offset of the plot
               ysize:0.0, $     ; The y size of the plot
               yoff:0.0, $       ; The y offset of the plot
               filename:'', $   ; The name of the output file
               inches:0, $       ; Inches or centimeters?
               color:0, $       ; Color on or off?
               bits_per_pixel:0, $ ; How many bits per image pixel?
               encapsulated:0,$ ; Encapsulated or regular PostScript?
	       isolatin1:0,$    ; Encoding is not ISOLATIN1
               landscape:0 }    ; Landscape or portrait mode?

  pctemplate = { cmps_form_CONFIG,  $
                 config:{cmps_form_INFO},  $
                 configname: '', $    ; Name of configuration
                 papersize: '' }      ; Size of paper for configuration
                 
  
  ; Set of default configurations (no ISOLATIN1 encoding)
  ;   1.  7x5    inch color plot region in portrait
  ;   2.  7.5x10 inch centered color plot region, covering almost whole
  ;                   portrait page (0.5 inch margins)
  ;   3.  10x7.5 inch centered color plot region, covering almost whole
  ;                   landscape page (0.5 inch margins)
  ;   4.  7x5    inch gray plot region in portrait (IDL default config)
  configs = [{cmps_form_CONFIG, config:$
              {cmps_form_INFO, 7.0, 0.75, 5.0, 5.0, 'idl.ps', 1, 1, 8, 0, 0, 0},$
              configname:'Half Portrait (color)', papersize:defaultpaper}, $
             {cmps_form_CONFIG, config:$
              {cmps_form_INFO, 7.5, 0.50, 10., 0.5, 'idl.ps', 1, 1, 8, 0, 0, 0},$
              configname:'Full Portrait (color)', papersize:defaultpaper}, $
             {cmps_form_CONFIG, config:$
              {cmps_form_INFO, 10., 0.50, 7.5, 10.5,'idl.ps', 1, 1, 8, 0, 0, 1},$
              configname:'Full Landscape (color)', papersize:defaultpaper}, $
             {cmps_form_CONFIG, config:$
              {cmps_form_INFO, 18., 1.5, 26.7, 1.5, 'idl.ps', 0, 1, 8, 0, 0, 0},$
              configname:'A4 Portrait (color)', papersize:'A4'}, $
             {cmps_form_CONFIG, config:$
              {cmps_form_INFO, 26.7, 1.5, 18.,28.2039,'idl.ps',0,1, 8, 0, 0, 1},$
              configname:'A4 Landscape (color)', papersize:'A4'}, $
             {cmps_form_CONFIG, config:$
              {cmps_form_INFO, 17.78,1.91,12.70,12.70,'idl.ps',0,1, 4, 0, 0, 0},$
              configname:'IDL Standard', papersize:defaultpaper} ]


  return
end

; 
; cmps_form_Update_Info
;
; This procedure modifies an "info" structure, according to new
; specifications about the PS configuration.  This is the central
; clearing house for self-consistent modification of the info structure.
;
; INPUTS
;   info    - info structure to be modified
;   keywords- IDL keywords are contain information is folded
;             into the "info" structure.
;             Valid keywords are:
;                XSIZE, YSIZE, 
;                XOFF, YOFF    - size and offset of plotting region in
;                                "human" coordinates.  This is the
;                                natural size as measured from the
;                                lower-left corner of the page in its
;                                proper orientation (not the IDL
;                                definition!).  These are the same
;                                values that are printed in the form's
;                                Size and Offset fields.
;                INCHES        - whether dimensions are in inches or
;                                centimeters (1=in, 0=cm)
;                COLOR         - whether output is color (1=y, 0=n)
;                BITS_PER_PIXEL- number of bits per pixel (2,4,8)
;                ENCAPSULATED  - whether output is EPS (1=EPS, 0=PS)
;                LANDSCAPE     - whether output is portrait or
;                                landscape (1=land, 0=port)
;                FILENAME      - output file name (with respect to
;                                current directory)
;
Pro cmps_form_Update_Info, info, set=set, _EXTRA=newdata

  if n_elements(newdata) GT 0 then $
    names = Tag_Names(newdata)
  set   = keyword_set(set)
  centerfactor = 1.0

  FOR j=0, N_Elements(names)-1 DO BEGIN
      
      case strupcase(names(j)) of
          'XSIZE':       info.devconfig.xsize    = float(newdata.xsize)
          'YSIZE':       info.devconfig.ysize    = float(newdata.ysize)
          'XOFF':        info.devconfig.xoff     = float(newdata.xoff)
          'YOFF':        info.devconfig.yoff     = float(newdata.yoff)
          'INCHES':      BEGIN
              inches   = fix(newdata.inches)
              if inches NE 0 then inches = 1
              if set NE 1 then begin
                  convfactor = 1.0
                  if info.devconfig.inches EQ 0 AND inches EQ 1 then $
                    convfactor = 1.0/2.54 $ ; centimeters to inches
                  else if info.devconfig.inches EQ 1 AND inches EQ 0 then $
                    convfactor = 2.54 ; inches to centimeters

                  info.devconfig.xsize = info.devconfig.xsize * convfactor
                  info.devconfig.ysize = info.devconfig.ysize * convfactor
                  info.devconfig.xoff  = info.devconfig.xoff  * convfactor
                  info.devconfig.yoff  = info.devconfig.yoff  * convfactor
                  info.xpagesize       = info.xpagesize       * convfactor
                  info.ypagesize       = info.ypagesize       * convfactor
                  info.marginsize      = info.marginsize      * convfactor
                  info.drawpixperunit  = info.drawpixperunit  / convfactor
                    
              endif
                  
              info.devconfig.inches = inches
          end
          
          'LANDSCAPE':   begin
              landscape= fix(newdata.landscape)
              if landscape NE 0 then landscape = 1
              
              if landscape NE info.devconfig.landscape AND $
                set NE 1 then begin
                  temp = info.xpagesize
                  info.xpagesize = info.ypagesize
                  info.ypagesize = temp
                  
                  ; Since the margins are bound to be way out of wack,
                  ; we could recenter here.
                  
                  xsize = info.devconfig.xsize
                  ysize = info.devconfig.ysize

                  centerfactor = 2.0
                  
                  ; We will have to redraw the reserve pixmap
                  info.pixredraw = 1
                  
              endif 
              
              info.devconfig.landscape = landscape
          end
          
          'COLOR':       begin
              info.devconfig.color    = fix(newdata.color)
              if info.devconfig.color        NE 0 then info.devconfig.color = 1
          end
          'ENCAPSULATED':  begin
              info.devconfig.encapsulated = fix(newdata.encapsulated)
              if info.devconfig.encapsulated NE 0 then $
                info.devconfig.encapsulated = 1
          end
          'ISOLATIN1': begin
              info.devconfig.isolatin1 = fix(newdata.isolatin1)
              if info.devconfig.isolatin1 NE 0 then $
                info.devconfig.isolatin1 = 1
          end
          'BITS_PER_PIXEL': begin
              bpp = fix(newdata.bits_per_pixel)
              if bpp LT 1              then bpp = 2
              if bpp GT 2 AND bpp LT 4 then bpp = 4
              if bpp GT 4 AND bpp LT 8 then bpp = 8
              if bpp GT 8              then bpp = 8
              info.devconfig.bits_per_pixel = bpp
          end
          'FILENAME': begin
              if string(newdata.filename) NE info.devconfig.filename then $
                info.filechanged = 1
              info.devconfig.filename = string(newdata.filename)
          end
      endcase
  endfor
  
  ; Now check the sizes and offsets, to be sure they are sane for the 
  ; particular landscape/portrait and inch/cm settings that have been
  ; chosen.
  pgwid = info.xpagesize
  pglen = info.ypagesize
  pgmar = info.marginsize

  if set NE 1 then begin
      info.devconfig.xsize = (pgmar) > info.devconfig.xsize < (pgwid-2.*pgmar)
      info.devconfig.ysize = (pgmar) > info.devconfig.ysize < (pglen-2.*pgmar)
      info.devconfig.xoff  = (pgmar) > info.devconfig.xoff  < (pgwid-info.devconfig.xsize - pgmar)
      info.devconfig.yoff  = (pgmar) > info.devconfig.yoff  < (pglen-info.devconfig.ysize - pgmar)
      if info.devconfig.xsize + info.devconfig.xoff GT (pgwid-pgmar) then $
        info.devconfig.xoff = (pgwid - info.devconfig.xsize) / centerfactor
      if info.devconfig.ysize + info.devconfig.yoff GT (pglen-pgmar) then $
        info.devconfig.yoff = (pglen - info.devconfig.ysize) / centerfactor
  endif

  ; Preserve aspect ratio if necessary
  if (info.preserve_aspect EQ 1) then begin
      sizeratio = info.aspect / (info.ypagesize / info.xpagesize)
      if (sizeratio GE 1) then $
        info.devconfig.xsize = info.devconfig.ysize / info.aspect $
      else $
        info.devconfig.ysize = info.devconfig.xsize * info.aspect
  endif

  return
end

; 
; PRO cmps_form_DRAW_BOX
;
; Draw the "sample" box in the draw widget.  If necessary, also
; redraws the backing reserve pixmap.
;
pro cmps_form_draw_box, xsize, ysize, xoff, yoff, info

  ; First order of business is to make a new reserve pixmap, if
  ; necessary.

  if info.pixredraw EQ 1 then begin
      
      ; Operate on the pixmap first
      wset, info.idpixwid
      erase
      ; Make background ...
      tv, replicate(info.bkgcolor, info.xpixwinsize, info.ypixwinsize)
      ; ... and page outline
      coords = cmps_form_plotbox_coords(info.xpagesize, info.ypagesize, $
                                      0.,0., info.drawpixperunit)
      plots, coords(0,*), coords(1,*), /device, color=info.pagecolor

      info.pixredraw = 0
  endif

  ; Now, we transfer the reserve pixmap to the screen

  wset, info.idwid
  device, copy=[0, 0, info.xpixwinsize, info.ypixwinsize, 0, 0, $
                info.idpixwid]

  ; Finally we overlay the plot region
  coords = cmps_form_plotbox_coords(xsize, ysize, xoff, yoff,info.drawpixperunit)
  plots, coords(0,*), coords(1,*), color=info.boxcolor, /device

  return
end

; 
; cmps_form_DRAW_FORM
;
; Update the widget elements of the cmps_form form, using the INFO structure.
;
; If the NOBOX keyword is set, then the draw widget is not updated.
;
pro cmps_form_draw_form, info, nobox=nobox

  ; Draw the DRAW widget if needed
  if NOT keyword_set(nobox) then $
    cmps_form_draw_box, info.devconfig.xsize, info.devconfig.ysize, $
    info.devconfig.xoff, info.devconfig.yoff, info

  ; Update the numeric text fields
  xsizestr = strtrim(string(info.devconfig.xsize, format='(F6.2)'), 2)
  ysizestr = strtrim(string(info.devconfig.ysize, format='(F6.2)'), 2)
  xoffstr  = strtrim(string(info.devconfig.xoff, format='(F6.2)'), 2)
  yoffstr  = strtrim(string(info.devconfig.yoff, format='(F6.2)'), 2)

  widget_control, info.idxsize, set_value=xsizestr
  widget_control, info.idysize, set_value=ysizestr
  widget_control, info.idxoff, set_value=xoffstr
  widget_control, info.idyoff, set_value=yoffstr

  widget_control, info.idaspect, set_button=(info.preserve_aspect EQ 1)

  ; Set EPS (encapsulated ps) buttons
  Widget_Control, info.idencap, Set_Button=(info.devconfig.encapsulated EQ 1)

   ; Set color buttons.
  Widget_Control, info.idcolor, Set_Button=(info.devconfig.color EQ 1)

  ; Set inch/cm buttons.
  Widget_Control, info.idinch, Set_Button=(info.devconfig.inches EQ 1)
  Widget_Control, info.idcm,   Set_Button=(info.devconfig.inches EQ 0)

  ; Set bits_per_pixel buttons.
  Widget_Control, info.idbit2, Set_Button=(info.devconfig.bits_per_pixel EQ 2)
  Widget_Control, info.idbit4, Set_Button=(info.devconfig.bits_per_pixel EQ 4)
  Widget_Control, info.idbit8, Set_Button=(info.devconfig.bits_per_pixel EQ 8)
  Widget_Control, info.idbitbase, Sensitive=(info.devconfig.color EQ 1)

  ; Set encoding button
  widget_control, info.idisolatin1, Set_Button=(info.devconfig.isolatin1 EQ 1)

  ; Set default filename.
  Widget_Control, info.idfilename, Get_Value=wfilename
  if string(wfilename(0)) NE info.devconfig.filename then begin
      Widget_Control, info.idfilename, Set_Value=info.devconfig.filename
      ; Put caret at end of pathname text so that filename itself is visible
      Widget_Control, info.idfilename, $
        Set_Text_Select=[ strlen(info.devconfig.filename), 0 ]
  endif

  ; Set protrait/landscape button.
  Widget_Control, info.idland, Set_Button=(info.devconfig.landscape EQ 1)
  Widget_Control, info.idport, Set_Button=(info.devconfig.landscape EQ 0)

  ; Set Paper
  pn = cmps_form_papernames()
  xp = strtrim(string(info.xpagesize, format='(F10.2)'),2)
  yp = strtrim(string(info.ypagesize, format='(F10.2)'),2)
  un = 'in'
  if NOT info.devconfig.inches then un = 'cm'

  paperlab = string(pn(info.paperindex), xp, un, yp, un, $
                      format='("   Paper: ",A0," (",A0,A0," x ",A0,A0,")   ")')
  Widget_Control, info.idpaperlabel, set_value=paperlab
  
  return
end

Pro cmps_form_Null_Events, event
END ;*******************************************************************

Function cmps_form_What_Button_Type, event

   ; Checks event.type to find out what kind of button
   ; was clicked in a draw widget. This is NOT an event handler.

type = ['DOWN', 'UP', 'MOTION', 'SCROLL']
Return, type(event.type)
END ;*******************************************************************

Function cmps_form_What_Button_Pressed, event

   ; Checks event.press to find out what kind of button
   ; was pressed in a draw widget.  This is NOT an event handler.

button = ['NONE', 'LEFT', 'MIDDLE', 'NONE', 'RIGHT']
Return, button(event.press)
END ;*******************************************************************

Function cmps_form_What_Button_Released, event

   ; Checks event.release to find out what kind of button
   ; was released in a draw widget.  This is NOT an event handler.

button = ['NONE', 'LEFT', 'MIDDLE', 'NONE', 'RIGHT']
Return, button(event.release)
END ;*******************************************************************



;
; cmps_form_NUMEVENTS
;
; Events sent to the numeric text field widgets are sent here.  We
; harvest the data values from the text field and update the screen.
;
Pro cmps_form_NumEvents, event

   ; If an event comes here, read the offsets and sizes from the
   ; form and draw the appropriately sized box in the draw widget.

Widget_Control, event.top, Get_UValue= info, /No_Copy

   ; Get current values for offset and sizes

Widget_Control, info.idxsize, Get_Value=xsize
Widget_Control, info.idysize, Get_Value=ysize
Widget_Control, info.idxoff, Get_Value=xoff
Widget_Control, info.idyoff, Get_Value=yoff

xsize = xsize(0)
ysize = ysize(0)
xoff = xoff(0)
yoff = yoff(0)

if info.preserve_aspect EQ 1 then begin
    if event.id EQ info.idysize then xsize = ysize / info.aspect $
    else                             ysize = xsize * info.aspect
endif

; Fold this information into the "info" structure
cmps_form_update_info, info, xsize=xsize, ysize=ysize, xoff=xoff, yoff=yoff

; Update form and redraw sample box
cmps_form_draw_form, info

; Put the info structure back into the top-level base

Widget_Control, event.top, Set_UValue=info, /No_Copy

END ;*******************************************************************


Pro cmps_form_Move_Box, event

   ; This is the event handler that allows the user to "move"
   ; the plot box around in the page window. It will set the
   ; event handler back to "cmps_form_Box_Events" when it senses an
   ; "UP" draw button event and it will also turn cmps_form_Draw_Motion_Events
   ; OFF.

   ; Get the info structure out of the top-level base.

  Widget_Control, event.top, Get_UValue=info, /No_Copy

  whatButtonType = cmps_form_What_Button_Type(event)

  dpu = info.drawpixperunit

  ixmin = 0.
  iymin = 0.
  ixsize = info.devconfig.xsize
  iysize = info.devconfig.ysize
  cmps_form_draw_coords, dpu, ixmin, iymin, ixsize, iysize
  ; Now ixmin,iymin have the minimum values of x and y, in pixels
  ; ixsize and iysize are the size of the box, in pixels

  ixmax = info.xpagesize
  iymax = info.ypagesize
  cmps_form_draw_coords, dpu, ixmax, iymax
  ; ixmax and iymax are the max values of x and y, in pixels

  ; info.ideltx/y contains the offset of the lower left corner of the box,
  ; with respect to the mouse's position
  ixoff = event.x + info.ideltx
  iyoff = event.y + info.idelty

  ; Keep box inside the page
  if ixoff LT ixmin then ixoff = ixmin
  if iyoff LT iymin then iyoff = iymin
  if (ixoff+ixsize) GT ixmax then ixoff = ixmax - ixsize
  if (iyoff+iysize) GT iymax then iyoff = iymax - iysize

  IF whatButtonType EQ 'UP' THEN Begin

      ; When the button is "up" the moving event is over.  We reset the
      ; event function and update the information about the box's position
      
      Widget_Control, info.iddraw, Draw_Motion_Events=0, $ ; Motion events off
        Event_Pro='cmps_form_Box_Events' ; Change to normal processing
      
      cmps_form_real_coords, dpu, ixoff, iyoff, ixsize, iysize
      
      ; Update the info structure
      cmps_form_update_info, info, xoff=ixoff, yoff=iyoff
      ; Draw it
      cmps_form_draw_form, info
      
      ; Put the info structure back in the top-level base and RETURN
      Widget_Control, event.top, Set_UValue=info, /No_Copy
      Return

  ENDIF

   ; You come to this section of the code for all events except
   ; an UP button event. Most of the action in this event handler
   ; occurs here.

  cmps_form_real_coords, dpu, ixoff, iyoff, ixsize, iysize

  ; Simply draw the new box
  cmps_form_draw_box, ixsize, iysize, ixoff, iyoff, info

  ; Put the info structure back into the top-level base.
  Widget_Control, event.top, Set_UValue=info, /No_Copy

END ;*******************************************************************


Pro cmps_form_Grow_Box, event

   ; This event handler is summoned when a RIGHT button is clicked
   ; in the draw widget. It allows the user to draw the outline of a
   ; box with the mouse. It will continue drawing the new box shape
   ; until an UP event is detected. Then it will set the event handler
   ; back to cmps_form_Box_Events and turn cmps_form_Draw_Motion_Events to OFF.

   ; Get the info structure out of the top-level base.

  Widget_Control, event.top, Get_UValue=info, /No_Copy

  whatButtonType = cmps_form_What_Button_Type(event)

  dpu = info.drawpixperunit

  ixmin = 0.
  iymin = 0.
  ixsize = info.devconfig.xsize
  iysize = info.devconfig.ysize
  cmps_form_draw_coords, dpu, ixmin, iymin, ixsize, iysize
  ; Now ixmin,iymin have the minimum values of x and y, in pixels
  ; ixsize and iysize are the size of the box, in pixels

  ixmax = info.xpagesize
  iymax = info.ypagesize
  cmps_form_draw_coords, dpu, ixmax, iymax
  ; ixmax and iymax are the max values of x and y, in pixels

  ; Keep box inside the page
  if event.x LT ixmin then event.x = ixmin
  if event.x GT ixmax then event.x = ixmax
  if event.y LT iymin then event.y = iymin
  if event.y GT iymax then event.y = iymax

  ; Decide on which corner is the lower left (it's arbitrary)
  ixoff  = min([info.imousex, event.x])
  iyoff  = min([info.imousey, event.y])
  ixsize = max([info.imousex, event.x]) - ixoff
  iysize = max([info.imousey, event.y]) - iyoff

  ;; Enforce the aspect ratio
  if info.preserve_aspect EQ 1 then begin
      sizeratio = info.aspect / (info.ypagesize / info.xpagesize)
      if (sizeratio GE 1) then ixsize = iysize / info.aspect $
      else iysize = ixsize * info.aspect
      if info.imousex GT event.x then ixoff = info.imousex - ixsize
      if info.imousey GT event.y then iyoff = info.imousey - iysize
  endif

  IF whatButtonType EQ 'UP' THEN Begin

      ; When the button is "up" the moving event is over.  We reset the
      ; event function and update the information about the box's position

      Widget_Control, info.iddraw, Draw_Motion_Events=0, $ ; Motion events off
        Event_Pro='cmps_form_Box_Events' ; Change to normal processing

      cmps_form_real_coords, dpu, ixoff, iyoff, ixsize, iysize

      ; Update the info structure
      cmps_form_update_info, info, xoff=ixoff, yoff=iyoff, $
        xsize=ixsize, ysize=iysize
      ; Draw it
      cmps_form_draw_form, info

      ; Put the info structure back in the top-level base and RETURN
      Widget_Control, event.top, Set_UValue=info, /No_Copy
      Return
      
  ENDIF

   ; This is the portion of the code that handles all events except for
   ; UP button events. The bulk of the work is done here. Basically,
   ; you need to erase the old box and draw a new box at the new
   ; location. Just keep doing this until you get an UP event.

  cmps_form_real_coords, dpu, ixoff, iyoff, ixsize, iysize

  ; Simply draw the new box
  cmps_form_draw_box, ixsize, iysize, ixoff, iyoff, info

  ; Put the info structure back in the top-level base.
  Widget_Control, event.top, Set_UValue=info, /No_Copy

END ;*******************************************************************



; 
; Buttondown events sent to this procedure at first.  This is sets up
; the initial move/drag elements and hands off the events to the more
; specialized procedures cmps_form_grow_box and cmps_form_move_box above.
;
Pro cmps_form_Box_Events, event

  whatButtonType = cmps_form_What_Button_Type(event)
  IF whatButtonType NE 'DOWN' THEN Return

  ; Get info structure out of TLB

  Widget_Control, event.top, Get_UValue=info, /No_Copy

  whatButtonPressed = cmps_form_What_Button_Pressed(event)

  dpu = info.drawpixperunit
  ixmin = 0.
  iymin = 0.
  ixsize = info.devconfig.xsize
  iysize = info.devconfig.ysize
  cmps_form_draw_coords, dpu, ixmin, iymin, ixsize, iysize
  ixmax = info.xpagesize
  iymax = info.ypagesize
  cmps_form_draw_coords, dpu, ixmax, iymax
  ixoff = info.devconfig.xoff
  iyoff = info.devconfig.yoff
  cmps_form_draw_coords, dpu, ixoff, iyoff

  if event.x LT ixmin OR event.x GT ixmax $
    OR event.y LT iymin OR event.y GT iymax then begin
      widget_control, event.top, set_uvalue=info, /no_copy
      return
  endif
  
  CASE whatButtonPressed OF
      
      'RIGHT': Begin
          
         ; Resize the plot box interactively. Change the event handler
         ; to cmps_form_Grow_Box. All subsequent events will be handled by
         ; cmps_form_Grow_Box until an UP event is detected. Then you will
         ; return to this event handler. Also, turn motion events ON.
          
          Widget_Control, event.id, Event_Pro='cmps_form_Grow_Box', $
            Draw_Motion_Events=1
          
          cmps_form_draw_box, 1./dpu, 1./dpu, ixoff, iyoff, info
          
          info.imousex = event.x
          info.imousey = event.y
          
      End
      
      'LEFT': Begin
          
         ; Resize the plot box interactively. Change the event handler
         ; to cmps_form_Move_Box. All subsequent events will be handled by
         ; cmps_form_Move_Box until an UP event is detected. Then you will
         ; return to this  event handler. Also, turn motion events ON.


         ; Only move the box if the cursor is inside the box.
         ;If it is NOT, then RETURN.

          if event.x LT ixoff OR event.x GT (ixoff+ixsize) OR $
            event.y LT iyoff OR event.y GT (iyoff+iysize) then begin 
              
              Widget_Control, event.top, Set_UValue=info, /No_Copy
              Return
          ENDIF
          
       ; Relocate the event handler and turn motion events ON.

          Widget_Control, event.id, Event_Pro='cmps_form_Move_Box', $
            Draw_Motion_Events=1
          
          ; ideltx and idelty contain the offset of the lower left 
          ; corner of the plot region with respect to the mouse.
          info.ideltx  = ixoff - event.x
          info.idelty  = iyoff - event.y
          
      End

      ELSE:                     ; Middle button ignored in this program

  ENDCASE

   ; Put the info structure back into the top-level base

  Widget_Control, event.top, Set_UValue=info, /No_Copy

END ;*******************************************************************

; 
; Handle events to the drop-list widgets, which contain predefined
; configurations.
;
pro cmps_form_predef_events, event

  name = tag_names(event, /structure_name)
  if strupcase(name) NE 'WIDGET_DROPLIST' then return

   ; Get the info structure out of the top-level base
  Widget_Control, event.top, Get_UValue=info, /No_Copy

  Widget_Control, event.id, Get_UValue=thislist

  ; Pre-read the values from the text fields
  Widget_Control, info.idfilename, Get_Value=filename
  cmps_form_update_info, info, filename=filename

  case thislist of
      'PAPER':  info.paperindex = event.index   ; Paper change 
      'PREDEF': begin
          old_filename = info.devconfig.filename         ; Keep old filename
          info.devconfig = info.predefined(event.index)  ; New config
          info.paperindex = info.papersizes(event.index) ; New paper too
          if info.filechanged then $
            info.devconfig.filename = old_filename $
          else begin
              cd, current=thisdir
              l = strlen(thisdir)
              if strmid(info.devconfig.filename, 0, l) NE thisdir then $
                info.devconfig.filename = old_filename $
              else $
                info.devconfig.filename = filepath(info.devconfig.filename, $
                                                   root_dir=thisdir)
          endelse
      end
  endcase

  ; Be sure to select a pristine set of paper
  cmps_form_select_papersize, info.paperindex, xpagesize, ypagesize, $
    landscape=info.devconfig.landscape, inches=info.devconfig.inches
  info.xpagesize = xpagesize
  info.ypagesize = ypagesize

  widget_control, info.idpaperlist, set_droplist_select=info.paperindex

  ; Reset the drawpixperunit value
  convfactor = 1.0
  if info.devconfig.inches EQ 0 then convfactor = convfactor * 2.54
  info.marginsize = 0.25 * convfactor

  ; The conversion between length and pixels cannot always be set precisely,
  ; depending on the size of the paper
  dpp = 10.0 / convfactor  ; Desire 10 pixels per inch
  if dpp * info.xpagesize GT info.xpixwinsize OR $
    dpp * info.ypagesize GT info.ypixwinsize then $
    dpp = min( [ float(info.xpixwinsize-2)/info.xpagesize, $
                 float(info.ypixwinsize-2)/info.ypagesize ])
  info.drawpixperunit = dpp
  info.pixredraw = 1

  ; Update the info structure and draw it
  cmps_form_update_info, info, xoff=info.devconfig.xoff
  cmps_form_draw_form, info

  Widget_Control, event.top, Set_UValue=info, /No_Copy
  return
end

;
; Handle events sent to any of the button elements of the form.
;
Pro cmps_form_Event, event

   ; This is the main event handler for cmps_form. It handles
   ; the exclusive buttons on the form. Other events on the form
   ; will have their own event handlers.

   ; Get the name of the event structure

  name = Tag_Names(event, /Structure_Name)

   ; Get the User Value of the Button
  Widget_Control, event.id, Get_UValue=thisButton

   ; If name is NOT "WIDGET_BUTTON" or this is not a button
   ; selection event, RETURN.
  nonexclusive = ( thisButton EQ 'ISOLATIN1' OR $
                   thisButton EQ 'COLOR' OR $
                   thisButton EQ 'ENCAPSULATED' OR $
                   thisButton EQ 'ASPECT' )

  IF name NE 'WIDGET_BUTTON' OR $
     (NOT nonexclusive AND event.select NE 1)  THEN Return

   ; Get the info structure out of the top-level base
  Widget_Control, event.top, Get_UValue=info, /No_Copy


  redraw_form = 0
  redraw_box = 0

  ; Pre-read the values from the text fields
  Widget_Control, info.idxsize, Get_Value=xsize
  Widget_Control, info.idysize, Get_Value=ysize
  Widget_Control, info.idxoff, Get_Value=xoff
  Widget_Control, info.idyoff, Get_Value=yoff
  Widget_Control, info.idfilename, Get_Value=filename
  cmps_form_update_info, info, filename=filename

   ; Respond appropriately to whatever button was selected
  CASE thisButton OF

      'INCHES': Begin
          cmps_form_update_info, info, xsize=xsize, ysize=ysize, $
            xoff=xoff, yoff=yoff
          cmps_form_update_info, info, inches=1
          redraw_form = 1
      end
          
      'CENTIMETERS': Begin
          cmps_form_update_info, info, xsize=xsize, ysize=ysize, $
            xoff=xoff, yoff=yoff
          cmps_form_update_info, info, inches=0
          redraw_form = 1
      End
      
      'COLOR': Begin
          cmps_form_update_info, info, color=(1-info.devconfig.color)
          redraw_form = 1
      End

      'BITS2': Begin
          cmps_form_update_info, info, bits_per_pixel=2
          redraw_form = 1
      End

      'BITS4': Begin
          cmps_form_update_info, info, bits_per_pixel=4
          redraw_form = 1
      End

      'BITS8': Begin
          cmps_form_update_info, info, bits_per_pixel=8
          redraw_form = 1
      End

      'ISOLATIN1': Begin
          cmps_form_update_info, info, isolatin1=(1-info.devconfig.isolatin1)
       End

      'ASPECT': begin
          if info.preserve_aspect EQ 0 then $
            info.aspect = info.devconfig.ysize / info.devconfig.xsize
          info.preserve_aspect = (1 - info.preserve_aspect)
      end

      'LANDSCAPE': Begin
          cmps_form_update_info, info, xsize=xsize, ysize=ysize, $
            xoff=xoff, yoff=yoff
          cmps_form_update_info, info, landscape=1
          redraw_form = 1
          redraw_box = 1
      End

      'PORTRAIT': Begin
          cmps_form_update_info, info, landscape=0
          cmps_form_update_info, info, xsize=xsize, ysize=ysize, $
            xoff=xoff, yoff=yoff
          redraw_form = 1
          redraw_box = 1
      End

      'ENCAPSULATED': Begin
          cmps_form_update_info, info, encapsulated=(1-info.devconfig.encapsulated)
      End

      'ACCEPT': Begin

         ; The user wants to accept the information in the form.
         ; The procedure is to gather all the information from the
         ; form and then fill out a formInfo structure variable
         ; with the information. The formInfo structure is stored
         ; in a pointer. The reason for this is that we want the
         ; information to exist even after the form is destroyed.

         ; Gather the information from the form

          Widget_Control, info.idfilename, Get_Value=filename
          cmps_form_update_info, info, xsize=xsize, ysize=ysize, $
            xoff=xoff, yoff=yoff
          cmps_form_update_info, info, filename=filename
          widget_control, event.id, get_value=buttonname

          formInfo = { $
                       cancel:0, $            ; CANCEL flag
                       create:0, $            ; CREATE flag
                       buttonname: buttonname, $
                       xpagesize:info.xpagesize, $
                       ypagesize:info.ypagesize, $
                       paperindex:info.paperindex, $
                       result:info.devconfig $; Results are ready-made
                     }

          goto, FINISH_DESTROY
      End

      'CREATE': Begin

          Widget_Control, info.idfilename, Get_Value=filename
          cmps_form_update_info, info, xsize=xsize, ysize=ysize, $
            xoff=xoff, yoff=yoff
          cmps_form_update_info, info, filename=filename

          formInfo = { $
                       cancel:0, $            ; CANCEL flag
                       create:1, $            ; CREATE flag
                       buttonname: 'Create File', $ 
                       xpagesize:info.xpagesize, $
                       ypagesize:info.ypagesize, $
                       paperindex:info.paperindex, $
                       result:info.devconfig $; Results are ready-made
                     }

          goto, FINISH_DESTROY

      End

      'CANCEL': Begin

         ; The user wants to cancel out of this form. We need a way to
         ; do that gracefully. Our method here is to set a "cancel"
         ; field in the formInfo structure.
          formInfo = {cancel:1, create:0}

          goto, FINISH_DESTROY
      End

  ENDCASE

  if redraw_form EQ 1 then $
    cmps_form_draw_form, info, nobox=(1-redraw_box)

   ; Put the info structure back into the top-level base if the
   ; base is still in existence.

  If Widget_Info(event.top, /Valid) THEN $
    Widget_Control, event.top, Set_UValue=info, /No_Copy
  return


  ; We only reach this stage if we are ending the cmps_form widget
  ; These commands store the results, restore colors, and destroy
  ; the form widget.
  FINISH_DESTROY:

         ; Put the formInfo structure into the location pointer
         ; to by the pointer
  Handle_Value, info.ptrresult, formInfo, /Set, /No_Copy

         ; Delete the pixmap window
  WDelete, info.idpixwid

         ; Restore the user's color table
  TVLct, info.red, info.green, info.blue

         ; Destroy the cmps_form widget program
  Widget_Control, event.top, /Destroy

  return

END ;*******************************************************************

Function cmps_form, xoffset, yoffset, Cancel=cancelButton, Help=help, $
     XSize=xsize, YSize=ysize, XOffset=xoff, YOffset=yoff, $
     Inches=inches, Color=color, Bits_Per_Pixel=bits_per_pixel, $
     Encapsulated=encapsulated, Landscape=landscape, Filename=filename, $
     Defaults=defaults, LocalDefaults=localDefaults, Initialize=initialize, $
     select=select, parent=parent, $
     Create=createButton, NoCommon=nocommon, PaperSize=paperSize, $
     button_names=buttons, button_sel=button_sel, $
     PreDefined=predefined, DefaultPaper=defaultpaper, $
     aspect=aspect, preserve_aspect=preserve_aspect, $
     xpagesize=xpagesize, ypagesize=ypagesize, pagebox=pagebox

   ; If the Help keyword is set, print some help information and return

  IF Keyword_Set(help) THEN BEGIN
      Doc_Library, 'cmps_form'
      RETURN, 0
  ENDIF

  ; Set cancelButton and createButton as if canceled, so will be defined
  ; (and with appropriate values) even if user kills the window instead of
  ; using the buttons.  Normal exit will reassign them later on.
  cancelButton = 1
  createButton = 0

  ; Load default setups via a common block, if they are available
  if n_elements(predefined) EQ 0 then begin
      common cmps_form_configs, cmps_form_default_papersize, $
        cmps_form_stdconfigs
      if n_elements(cmps_form_stdconfigs) GT 0 then $
        predefined = cmps_form_stdconfigs
  endif

  ; If the user has not set up a common block, then get some pre
  if n_elements(predefined) EQ 0 then $
    cmps_form_load_configs, cmps_form_default_papersize, predefined

  ; Transfer to local copies so that we don't overwrite
  confignames = predefined(*).configname
  configs     = predefined(*).config
  configs     = configs(*) ;; IDL 5.5 will make a 1xN array -- collapse it now
  papernames  = predefined(*).papersize
  if n_elements(defaultpaper) EQ 0 $
    AND n_elements(cmps_form_default_papersize) GT 0 then $
    defaultpaper = cmps_form_default_papersize
  if n_elements(defaultpaper) EQ 0 then $
    defaultpaper = 'Letter'

  papersizes = intarr(n_elements(papernames))

  ; If localdefaults exist, then enter them into a new first entry of 
  ; the configuration list
  if n_elements(localDefaults) NE 0 then begin
      configs     = [ configs(0), configs ]
      confignames = [ 'Local',    confignames ]
      papernames  = [defaultpaper, papernames ]
      papersizes  = [ 0,          papersizes ]

      tmpc = configs(0)
      struct_assign, localdefaults, tmpc, /nozero
      configs(0) = tmpc
  endif


  ; Generate a new entry at the beginning, which will be the initial, 
  ; default configuration.
  configs     = [ configs(0), configs ]
  confignames = [ 'Default',  confignames ]
  papernames  = [defaultpaper, papernames ]
  papersizes  = [ 0,          papersizes ]

  filechanged = 0
  defaultset = 0
  if n_elements(defaults) NE 0 then begin
      defaultset = 1
      tmpc = configs(0)
      struct_assign, defaults, tmpc, /nozero
      configs(0) = tmpc
      void = where( strupcase(Tag_Names(defaults)) EQ 'FILENAME', count )
      if (count NE 0) then filechanged = 1
  endif

  ; Next, enter in the keyword defaults
  IF NOT defaultset OR N_ELEMENTS(inches) GT 0 then begin
      if n_elements(inches) EQ 0 then inches = 1
      configs(0).inches    = keyword_set(inches)
  endif
  IF NOT defaultset OR n_elements(landscape) GT 0 then $
    configs(0).landscape = keyword_set(landscape)
  if NOT defaultset OR n_elements(color) GT 0 then $
    configs(0).color = keyword_set(color)
  if NOT defaultset OR n_elements(encapsulated) GT 0 then $
    configs(0).encapsulated = keyword_set(encapsulated)

  if NOT defaultset OR n_elements(bits_per_pixel) GT 0 then begin
      if n_elements(bits_per_pixel) EQ 0 then bpp = 8 else bpp = bits_per_pixel
      if bpp LT 1              then bpp = 2
      if bpp GT 2 AND bpp LT 4 then bpp = 4
      if bpp GT 4 AND bpp LT 8 then bpp = 8
      if bpp GT 8              then bpp = 8
      configs(0).bits_per_pixel = bpp
  endif
  
  IF N_ELements(filename) EQ 0 THEN BEGIN
      if NOT filechanged then begin
          CD, Current=thisDir
          filename = Filepath('idl.ps', Root_Dir=thisDir)
          filechanged = 0
          configs(0).filename = filename
      endif
  ENDIF else begin
      configs(0).filename = filename
      filechanged = 1
  endelse

  ; Get the size of the page, based on the papersize keyword
  if n_elements(paperSize) GT 1 then begin
      xpagesize = float(paperSize(0))
      ypagesize = float(paperSize(1))
      pind = 0
  endif else begin
      if n_elements(paperSize) EQ 0 then papersize = defaultpaper
      cmps_form_select_papersize, papersize, xpagesize, ypagesize, $
        landscape=configs(0).landscape, inches=configs(0).inches, index=pind
  endelse
  
  convfactor = 1.0
  if configs(0).inches EQ 0 then convfactor = convfactor * 2.54
  defmarginsize = 1.50 * convfactor   ; 1 1/2 inch margins default
  
  if N_Elements(marginsize) EQ 0 then $
    marginsize    = 0.25 * convfactor ; 1/4 inch margins "minimum"

  ; "Unconvert" the configuration xoff, yoff, etc. into human-readable format,
  ; which is also the format of the keywords xoff and yoff passed to cmps_form()

  nconfigs = n_elements(configs)
  for j = 0, nconfigs-1 do begin
      cmps_form_select_papersize, papernames(j), tmpxpg, tmpypg, $
        landscape=configs(j).landscape, inches=configs(j).inches, $
        index=pind

      papersizes(j) = pind
      tmpc = configs(j)
      cmps_form_conv_pscoord, tmpc, tmpxpg, tmpypg, /tohuman
      configs(j) = tmpc
  endfor

  if n_elements(aspect) GT 0 then aspect = aspect(0) > .001
  if n_elements(ysize) GT 0 then ysize = ysize(0)
  if n_elements(xsize) GT 0 then xsize = xsize(0)
  if n_elements(xsize) GT 0 AND n_elements(ysize) GT 0 then $
    aspect = ysize / (xsize > (ysize*0.001)) $
  else if n_elements(xsize) GT 0 AND n_elements(aspect) GT 0 then $
    ysize = xsize * aspect $
  else if n_elements(ysize) GT 0 AND n_elements(aspect) GT 0 then $
    xsize = ysize / aspect

  ; Compute an intelligent default X and Y size, if they aren't given
  pageaspect = xpagesize / ypagesize

  if NOT defaultset then begin 
    if n_elements(xsize) EQ 0 AND n_elements(ysize) EQ 0 then begin
        if n_elements(aspect) EQ 0 then begin
            IF !D.Window NE -1 THEN $
              aspect = Float(!D.X_VSize) / !D.Y_VSize $
            ELSE $
              aspect = 1.0
        endif

        if aspect GT 1.0 then BEGIN
            configs(0).xsize = xpagesize-2.0*marginsize
            configs(0).ysize = configs(0).xsize / aspect
        endif else begin
            configs(0).ysize = ypagesize-2.0*marginsize
            configs(0).xsize = configs(0).ysize * aspect
        endelse
    endif
    if n_elements(xsize) EQ 0 then $
      configs(0).xsize = 7.0 * convfactor
    if n_elements(ysize) EQ 0 then $
      configs(0).ysize = 5.0 * convfactor
    if n_elements(xoff)  EQ 0 then $
      configs(0).xoff  = (xpagesize-configs(0).xsize) / 2.0
    if n_elements(yoff)  EQ 0 then $
      configs(0).yoff  = (ypagesize-configs(0).ysize) / 2.0
  
    configs(0).xsize = marginsize>configs(0).xsize<(xpagesize-2.*marginsize)
    configs(0).ysize = marginsize>configs(0).ysize<(ypagesize-2.*marginsize)
    configs(0).xoff  = marginsize>configs(0).xoff <(xpagesize-configs(0).xsize)
    configs(0).yoff  = marginsize>configs(0).yoff <(ypagesize-configs(0).ysize)
  endif

  if keyword_set(preserve_aspect) then begin
      if n_elements(xsize) EQ 0 then xsize = configs(0).xsize
      if n_elements(ysize) EQ 0 then ysize = configs(0).ysize
      aspect = ysize / (xsize > (ysize*0.001))
  endif

  if n_elements(xsize) GT 0 then configs(0).xsize = xsize
  if n_elements(ysize) GT 0 then configs(0).ysize = ysize
  if n_elements(xoff)  GT 0 then configs(0).xoff  = xoff
  if n_elements(yoff)  GT 0 then configs(0).yoff  = yoff
  if n_elements(aspect) EQ 0 then aspect = configs(0).ysize / configs(0).xsize

  ; Return the initialized information, if that's all they were asking
  ; for.  Must convert back to "IDL" coordinates.
  IF Keyword_Set(initialize) THEN BEGIN
      sel = 0
      if n_elements(select) GT 0 then begin
          selen = strlen(select)
          wh = where(strupcase(strmid(confignames,0,selen)) EQ $
                     strupcase(select), ct)
          if ct GT 0 then sel = wh(0)
      endif
      cmps_form_select_papersize, papernames(sel), tmpxpg, tmpypg, $
        landscape=configs(sel).landscape, inches=configs(sel).inches
      tmpc = configs(sel)
      xpagesize = tmpxpg & ypagesize = tmpypg
      pagebox = [(0-tmpc.xoff)/tmpc.xsize, $
                 (0-tmpc.yoff)/tmpc.ysize, $
                 (xpagesize-tmpc.xoff)/tmpc.xsize, $
                 (ypagesize-tmpc.yoff)/tmpc.ysize ]
      cmps_form_conv_pscoord, tmpc, tmpxpg, tmpypg, /toidl
      cancelButton = 0
      createButton = 0
      return, tmpc
  endif

   ; This program cannot work if the graphics device is already set
   ; to PostScript. So if it is, set it to the native OS graphics device.
   ; Remember to set it back later.

  IF !D.Name EQ 'PS' THEN BEGIN

      oldName = 'PS'
      thisDevice = Byte(!Version.OS)
      thisDevice = StrUpCase( thisDevice(0:2) )
      IF thisDevice EQ 'MAC' OR thisDevice EQ 'WIN' THEN Set_Plot, thisDevice $
      ELSE Set_Plot, 'X'

  ENDIF ELSE oldName = !D.Name

   ; Check for optional offset parameters and give defaults if not passed

  Device, Get_Screen_Size=screenSize
  IF N_Elements(xoffset) EQ 0 THEN xoffset = (screenSize(0) - 600) / 2.
  IF N_Elements(yoffset) EQ 0 THEN yoffset = (screenSize(1) - 400) / 2.
  
  ; The draw widget will have the following dimensions
  xpixwinsize = 174
  ypixwinsize = 174    ; Hopefully will fit 11" x 17" sized paper

  ; The conversion between length and pixels cannot always be set precisely,
  ; depending on the size of the paper
  dpp = 10.0 / convfactor  ; Desire 10 pixels per inch
  if dpp * xpagesize GT xpixwinsize OR dpp * ypagesize GT ypixwinsize then $
    dpp = min( [ float(xpixwinsize-2)/xpagesize, $
                 float(ypixwinsize-2)/ypagesize ])

  ; Start building the widgets
  thisRelease = StrMid(!Version.Release, 0, 1)
  if thisRelease EQ '5' AND n_elements(parent) GT 0 THEN $
    extra_modal = {Modal:1, Group_Leader:parent(0) }
  tlb0 = Widget_Base(Title='Configure PostScript Parameters', Column=1, $
                     XOffset=xoffset, YOffset=yoffset, TLB_Frame_Attr=9, $
                     _EXTRA=extra_modal)

   ; Sub-bases for layout
  tlb = Widget_Base(tlb0, Column=1, Align_Center=1, frame=1)

  sizebase = Widget_Base(tlb, Row=1,  Align_Center=1)

  numbase = Widget_Base(sizebase, Column=1)

      numsub1 = Widget_Base(numbase, Row=1)

         junk = Widget_Label(numsub1, Value=' Units: ')
             junksub = Widget_Base(numsub1, Row=1, /Exclusive)
                inch = Widget_Button(junksub, Value='Inches', UValue='INCHES')
                cm = Widget_Button(junksub, Value='Centimeters', $
                   UValue='CENTIMETERS')

      numsub2 = Widget_Base(numbase, Row=1, Event_Pro='cmps_form_NumEvents')

         xbase = Widget_Base(numsub2, Column=1, Base_Align_Right=1)
           x1base = Widget_Base(xbase, Row=1)
             junk   = Widget_Label(x1base, Value='XSize: ')
             xsizew = Widget_Text(x1base, Scr_XSize=60, /Editable, $
                                  Value='')

           x2base = Widget_Base(xbase, Row=1)
             junk  = Widget_Label(x2base, Value='XOffset: ')
             xoffw = Widget_Text(x2base, Scr_XSize=60, /Editable, $
                                 Value='')

         ybase = Widget_Base(numsub2, Column=1, Base_Align_Right=1)
           y1base = Widget_Base(ybase, Row=1)
             junk   = Widget_Label(y1base, Value='YSize: ')
             ysizew = Widget_Text(y1base, Scr_XSize=60, /Editable, $
                      Value='')

           y2base = Widget_Base(ybase, Row=1)
             junk  = Widget_Label(y2base, Value='YOffset: ')
             yoffw = Widget_Text(y2base, Scr_XSize=60, /Editable, $
                                 Value='')

     paperw = Widget_Label(numbase, $
       Value='                                        ' )
     dummy = widget_base(numbase, column=1, /nonexclusive)
     aspectw = widget_button(dummy, value='Preserve Aspect', uvalue='ASPECT')

   drawbase = Widget_Base(sizebase, Row=1, frame=1)

   draw = Widget_Draw(drawbase, XSize=xpixwinsize, YSize=ypixwinsize, $
     Event_Pro='cmps_form_Box_Events', Button_Events=1)

   opttlb  = Widget_Base(tlb, Row=1, align_center=1, xpad=20)

   orientbase = Widget_Base(opttlb, Column=1, base_align_center=1)

   junk = Widget_Label(orientbase, Value='Orientation: ')
      junkbase = Widget_Base(orientbase, Column=1, /Frame, /Exclusive)
         land = Widget_Button(junkbase, Value='Landscape', UValue='LANDSCAPE')
         port = Widget_Button(junkbase, Value='Portrait', UValue='PORTRAIT')

   optbase = Widget_Base(opttlb, Column=1, /NonExclusive, frame=1)
     colorbut  = widget_button(optbase, Value='Color Output', $
                 uvalue='COLOR')
     encap     = Widget_Button(optbase, Value='Encapsulated (EPS)', $
                           uvalue='ENCAPSULATED')
     isolatin1 = widget_button(optbase, Value='ISOLatin1 Encoding', $
                 UValue='ISOLATIN1')

;   bitslabel = Widget_Label(opttlb, Value='   Color Bits:')

   bitsw = Widget_Base(opttlb, Column=1, /Exclusive, /frame)

      bit2 = Widget_Button(bitsw, Value='2 Bit Color', UValue='BITS2')
      bit4 = Widget_Button(bitsw, Value='4 Bit Color', UValue='BITS4')
      bit8 = Widget_Button(bitsw, Value='8 Bit Color', UValue='BITS8')

   filenamebase = Widget_Base(tlb, Column=1, Align_Center=1)
   fbase = Widget_Base(filenamebase, Row=1)
   textlabel = Widget_Label(fbase, Value='Filename: ')

       ; Set up text widget with an event handler that ignores any event.

   filenamew = Widget_Text(fbase, /Editable, Scr_XSize=300,  $
      Value='', Event_Pro='cmps_form_Null_Events')
   filenameb = widget_button(fbase, value='Choose...', $
                             event_pro='cmps_form_select_file')

   ; This is a base for selection of predefined configurations and paper sizes
   predefbase = Widget_Base(tlb0, row=1, /align_center, frame=1)
   junk = widget_label(predefbase, value='Predefined:')
   predlist = widget_droplist(predefbase, value=confignames, $
                          event_pro='cmps_form_predef_events', UValue='PREDEF')
   junk = widget_label(predefbase, value='    Paper Sizes:')
   paplist = widget_droplist(predefbase, value=cmps_form_papernames(),$
                          event_pro='cmps_form_predef_events', UValue='PAPER')
   
   actionbuttonbase = Widget_Base(tlb0, Row=1, /Align_Center)
   cancel = Widget_Button(actionbuttonbase, Value='Cancel', UValue='CANCEL')
   if n_elements(buttons) GT 0 then begin
       for i = 0, n_elements(buttons)-1 do begin
           but = widget_button(actionbuttonbase, value=buttons(i), $
                               uvalue='ACCEPT')
       endfor
   endif else begin
       create = Widget_Button(actionbuttonbase, Value='Create File', $
                              UValue='CREATE')
       accept = Widget_Button(actionbuttonbase, Value='Accept', $
                              UValue='ACCEPT')
   endelse


   ; Modify the color table 
   ; Get the colors in the current color table
   TVLct, r, g, b, /Get

   ; Modify color indices N_Colors-2, N_Colors-3 and N_Colors-4 for
   ; drawing colors

   ; The number of colors in the session can be less then the
   ; number of colors in the color vectors on PCs (and maybe other
   ; computers), so take the smaller value. (Bug fix?)
   ncol = !D.N_Colors < N_Elements(r)
   red = r
   green = g
   blue=b
   red(ncol-4:ncol-2) = [70B, 0B, 255B]
   green(ncol-4:ncol-2) = [70B, 255B, 255B]
   blue(ncol-4:ncol-2) = [70B, 0B, 0B]

   ; Load the newly modified colortable
   TVLct, red, green, blue

   ; Create a reserve pixmap for keeping backing store
   owin = !d.window
   Window, /Free, XSize=xpixwinsize, YSize=ypixwinsize, /Pixmap
   pixwid = !D.Window

   ; Create a handle.  This will hold the result after the widget finishes
   ptr = Handle_Create()

   info = { $
            devconfig: configs(0), $
            iddraw: draw, $
            idpixwid: pixwid, $
            idwid: pixwid, $
            idtlb: tlb0, $
            idxsize: xsizew, $
            idysize: ysizew, $
            idxoff: xoffw, $
            idyoff: yoffw, $
            idfilename: filenamew, $
            idinch: inch, $
            idcm: cm, $
            idcolor: colorbut, $
            idbitbase: bitsw, $
            idbit2: bit2, $
            idbit4: bit4, $
            idbit8: bit8, $
            idisolatin1: isolatin1, $
            idencap: encap, $
            idland: land, $
            idport: port, $
            idpaperlabel: paperw, $
            idaspect: aspectw, $
            idpaperlist: paplist, $
            xpagesize: xpagesize, $
            ypagesize: ypagesize, $
            paperindex: pind, $
            marginsize: marginsize, $
            xpixwinsize: xpixwinsize, $
            ypixwinsize: ypixwinsize, $
            drawpixperunit: dpp, $
            filechanged: filechanged, $
            pixredraw: 1, $
            imousex: 0.0, $
            imousey: 0.0, $
            ideltx: 0.0, $
            idelty: 0.0, $
            pagecolor: ncol-2, $
            boxcolor: ncol-3, $
            bkgcolor: ncol-4, $
            red: r, $
            green: g, $
            blue: b, $
            ptrresult: ptr, $
            predefined: configs, $
            papersizes: papersizes, $
            defaultpaper: defaultpaper, $
            aspect: aspect, $
            preserve_aspect: keyword_set(preserve_aspect) $
          }
   
   cmps_form_draw_form, info, /nobox
   Widget_Control, tlb0, /Realize
   Widget_Control, draw, Get_Value=wid
   info.idwid = wid

   ;; Make sure the current info is consistent
   cmps_form_update_info, info
   ; Draw the remaining widgets
   widget_control, paplist, Set_DropList_Select=pind
   cmps_form_draw_form, info

   ; Store the info structure in the top-level base

   Widget_Control, tlb0, Set_UValue=info, /No_Copy

   ; Set this widget program up as a modal or blocking widget. What this means
   ; is that you will return to the line after this XManager call when the
   ; widget is destroyed.

   thisRelease = StrMid(!Version.Release, 0, 1)
   if thisRelease EQ '4' then $
     xmanager_modal = {Modal:1}
   XManager, 'cmps_form', tlb0, _extra=xmanager_modal

   ; Get the formInfo structure from the pointer location.

   Handle_Value, ptr, formInfo, /No_Copy

   ; Make sure the user didn't click a close button.

   IF N_Elements(formInfo) EQ 0 THEN Begin
       Handle_Free, ptr
       RETURN, 0
   EndIF

   ; Strip the CANCEL field out of the formInfo structure so the
   ; cancelButton flag can be returned via the CANCEL keyword and the
   ; formInfo structure is suitable for passing directly to the DEVICE
   ; procedure through its _Extra keyword.

   cancelButton = formInfo.cancel
   createButton = formInfo.create
   IF NOT cancelButton THEN begin
       xpagesize = formInfo.xpagesize
       ypagesize = formInfo.ypagesize
       paperindex  = formInfo.paperindex
       if n_elements(buttons) GT 0 then $
         button_sel = forminfo.buttonname
       formInfo = formInfo.result 
       
       papersize = cmps_form_papernames()
       papersize = papersize(paperindex)
       pagebox = [(0-formInfo.xoff)/formInfo.xsize, $
                  (0-formInfo.yoff)/formInfo.ysize, $
                 (xpagesize-formInfo.xoff)/formInfo.xsize, $
                 (ypagesize-formInfo.yoff)/formInfo.ysize ]
       cmps_form_conv_pscoord, formInfo, xpagesize, ypagesize, /toidl
   endif else $
     formInfo = 0

   ; Free up the space allocated to the pointers and the data

   Handle_Free, ptr

   if owin GE 0 then wset, owin
   Set_Plot, oldname

   RETURN, formInfo
END ;*******************************************************************

;+
; NAME:
;   CMREPLICATE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Replicates an array or scalar into a larger array, as REPLICATE does.
;
; CALLING SEQUENCE:
;   ARRAY = CMREPLICATE(VALUE, DIMS)
;
; DESCRIPTION: 
;
;   The CMREPLICATE function constructs an array, which is filled with
;   the specified VALUE template.  CMREPLICATE is very similar to the
;   built-in IDL function REPLICATE.  However there are two
;   differences:
;
;      * the VALUE can be either scalar or an ARRAY.
;
;      * the dimensions are specified as a single vector rather than
;        individual function arguments.
;
;   For example, if VALUE is a 2x2 array, and DIMS is [3,4], then the
;   resulting array will be 2x2x3x4.
;
; INPUTS:
;
;   VALUE - a scalar or array template of any type, to be replicated.
;           NOTE: These two calls do not produce the same result:
;                  ARRAY = CMREPLICATE( 1,  DIMS)
;                  ARRAY = CMREPLICATE([1], DIMS)
;           In the first case the output dimensions will be DIMS and
;           in the second case the output dimensions will be 1xDIMS
;           (except for structures).  That is, a vector of length 1 is
;           considered to be different from a scalar.
;
;   DIMS - Dimensions of output array (which are combined with the
;          dimensions of the input VALUE template).  If DIMS is not
;          specified then VALUE is returned unchanged.
;
; RETURNS:
;   The resulting replicated array.  
;
; EXAMPLE:
;   x = [0,1,2]
;   help, cmreplicate(x, [2,2])
;     <Expression>    INT       = Array[3, 2, 2]
;   Explanation: The 3-vector x is replicated 2x2 times.
;
;   x = 5L
;   help, cmreplicate(x, [2,2])
;     <Expression>    LONG      = Array[2, 2]
;   Explanation: The scalar x is replicated 2x2 times.
;
; SEE ALSO:
;
;   REPLICATE
;
; MODIFICATION HISTORY:
;   Written, CM, 11 Feb 2000
;   Fixed case when ARRAY is array of structs, CM, 23 Feb 2000 
;   Apparently IDL 5.3 can't return from execute().  Fixed, CM, 24 Feb
;     2000
;   Corrected small typos in documentation, CM, 22 Jun 2000
;   Removed EXECUTE() call by using feature of REBIN() new in IDL 5.6,
;     (thanks to Dick Jackson) CM, 24 Apr 2009 
;   Remove some legacy code no longer needed after above change
;     (RETVAL variable no longer defined; thanks to A. van Engelen),
;     CM, 08 Jul 2009
;   Change to square bracket array index notation; there were reports
;     of funny business with parenthesis indexing (thanks Jenny Lovell),
;     CM, 2012-08-16
;
;-
; Copyright (C) 2000, 2009, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMRESTORE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Restore variables from an IDL SAVE file.
;
; CALLING SEQUENCE: (various)
;   CMRESTORE, filename                           (implicit)
;   CMRESTORE, filename, var1, var2, ..., [, NAMES=names]
;   CMRESTORE, filename, DATA=pointers, NAMES=names, PASS_METHOD='POINTER'
;   CMRESTORE, filename, DATA=handles,  NAMES=names, PASS_METHOD='HANDLE'
;   CMRESTORE, filename, DATA=structure,             PASS_METHOD='STRUCT'
;   
; DESCRIPTION: 
;
;   CMRESTORE is a replacement for the built-in IDL procedure RESTORE.
;   It restores variables and data from an existing IDL SAVE file,
;   written either by SAVE or CMSAVE.  The CMSV utility library must
;   be installed in your IDL path to use CMSAVE and CMRESTORE.
;
;   The primary advantage to CMRESTORE is the ability to selectively
;   restore only certain variables from the input file (based on
;   name).  CMRESTORE provides a number of ways to pass the data
;   between routines, typically using a pointer or structure, which
;   avoids the unsafe practice of restoring variables in the caller's
;   namespace.  However, CMRESTORE can restore variables into the
;   caller's namespace, but users should be aware that this capacity
;   is somewhat limited in IDL versions 5.2 and below.
;
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; COMPATIBILITY:
;
;   -- File Format --
;
;   CMRESTORE should be able to read files written by SAVE and CMSAVE
;   from IDL version 4 to version 5.4.
;
;   CMRESTORE cannot restore objects, pointers, compressed files, or
;   data sets larger than 2 gigabytes.
;   
;   Data types available in newer versions of IDL, such as pointers
;   and long integers, will not be readable in older versions of IDL
;   which do not have those data types.
;
;   -- Calling Interface --
;
;   For the most part, all capabilities of CMRESTORE are available to
;   the user.  However, it should be noted that passing variables by
;   positional parameter is not available under IDL 4, unless NAMES is
;   used to name the variables explicitly.  Also, under IDL versions
;   5.2 and previous, it is not possible for CMRESTORE to restore
;   variables into the caller's name space if they are not yet
;   defined.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; INPUTS:
;
;   FILENAME - the name of the SAVE file.
;              Default: none, this parameter must be specified.
;
;   VAR{i} - The values to be restored.  By default the save name is
;            taken from the named variables that are passed.  These
;            default names can be overridden by using the NAMES
;            keyword.
;
;            If no variables are passed as positional parameters, they
;            can still be saved using the DATA keyword.  By invoking
;            CMRESTORE without positional parameters or DATA,
;            CMRESTORE automatically will attempt to restore the
;            variables to the calling routine's name space (the
;            "implicit" technique).
;
;               NOTE: in IDL 5.2 and below, user routines are not
;               allowed to *CREATE* new variables in the caller's name
;               space.  CMRESTORE may fail if the variable in
;               undefined in the caller.  Therefore you must define it
;               before calling CMRESTORE.  The safer practice is to
;               use the VAR{i} positional parameters, or the DATA
;               keyword.
;
; KEYWORDS:
;
;   FILENAME - the name of the SAVE file.  The positional FILENAME
;              parameter takes precedence over the keyword FILENAME
;              parameter.
;
;              NOTE that if you pass variables as positional
;              parameters, then the first parameter *must* be the file
;              name, and the FILENAME *keyword* will be ignored.
;
;   PASS_METHOD - a scalar string, describing the method of passing
;                 data between the caller and CMRESTORE.  The keyword
;                 can take the value 'ARGUMENT', 'POINTER', 'HANDLE'
;                 or 'STRUCT'.  A value of 'ARGUMENT' indicates that
;                 data values will be passed by command line argument,
;                 and is the default.  Other values are described
;                 below.
;
;   DATA - A list of data elements to be restored from the output
;          file.  The data elements can be one of the following,
;          depending on the value of PASS_METHOD.  The means of
;          extracting the data, and the method of naming each
;          variable, are also indicated.
;
;            * PASS_METHOD='POINTER': An array of pointers to the variables
;                    Data: pointed-to value     Name: from NAMES keyword
;            * PASS_METHOD='HANDLE':  An array of handles to the variables
;                    Data: pointed-to value     Name: from NAMES keyword
;            * PASS_METHOD='STRUCT':  A structure containing data to be saved
;                    Data: tag value            Name: tag name
;
;          Data values are restored one by one, using the appropriate
;          name.  Note that any variables passed as positional
;          parameters will cause the DATA keyword to be ignored.
;
;          CMRESTORE will allocate any pointer or handle resources.
;          The calling routine is responsible for deallocating any
;          pointer or handle resources.
;
;   NAMES - a string array, giving the names for each variable.  
;
;           If the data are passed by positional parameters, the names
;           are assigned according to the position of the parameter in
;           the procedure call.  
;
;           If the data are passed by an array of pointers or handles,
;           then the names are assigned according to the position of
;           the data in the array.  In this case there is no other way
;           to supply the variable name.  NAMES is required.
;
;           If the data are passed in a structure, then the names are
;           assigned according to the position of the data in the
;           structure.  The values specified in the names keyword
;           override the tag names.
;
;   STATUS - upon return, an integer indicating the status of the
;            operation.  A value of 1 indicates success, while 0
;            indicates failure.  A failure condition does not
;            necessarily indicate that an individual variable could
;            not be restored; use the VARSTATUS keyword to detect such
;            situations.
;
;   VARSTATUS - upon return, an integer array indicating the status of
;               the restore operation for each variable.  A value of 1
;               at position i in the array indicates success for the
;               ith variable, while a value of 0 indicates failure.
;
;   ERRMSG - upon return, a string indicating the status of the
;            operation.  The empty string indicates success, while a
;            non-empty string indicates failure and describes the
;            error condition.
;
;   QUIET - if set, then the error message is returned to the calling
;           routine.  By default an error condition causes execution
;           to stop and the message to be printed on the console.
;
;   VERBOSE - if set, then a short message is printed for each
;             variable.
;
; EXAMPLE:
;
;   CMSAVE, VAR1, VAR2, FILENAME='test.sav'
;   CMSAVE, VAR1, VAR2, FILENAME='test.sav', NAMES=['A','B']
;
;     Save the data in VAR1 and VAR2 to the file test.sav.  In the
;     first case the saved variable names will be VAR1 and VAR2.  In
;     the second case the saved variable names will be A and B.
;
;   POINTERS = [ptr_new(VAR1), ptr_new(VAR2)]
;   CMSAVE, DATA=POINTERS, NAMES=['A','B'], FILENAME='test.sav'
;
;     Save the data in VAR1 and VAR2 to the file test.sav.  The saved
;     variable names will be A and B.
;
;   STRUCTURE = {A: VAR1, B: VAR2}
;   CMSAVE, DATA=STRUCTURE, FILENAME='test.sav'
;
;     Save the data in VAR1 and VAR2 to the file test.sav.  The saved
;     variable names will be A and B.
;
; SEE ALSO:
;
;   CMSAVE, SAVE, RESTORE
;
; MODIFICATION HISTORY:
;   Written, 14 May 2000
;   Documented, 22 Sep 2000
;   Restore into caller's name space now permitted, 11 Jan 2001
;   Documented "implicit" restore a little better, w/ errors, 01 Mar 2001
;   Make version checks with correct precision, 19 Jul 2001, CM
;   Restore with no args automatically does ALL, is this right?,
;     CM, 20 Aug 2001
;   Added notification about RSI License, 13 May 2002, CM
;   Handle the case of CMRESTORE, FILENAME, X properly, 03 Sep 2008, CM
;     (thanks to Sergey Koposov for reporting)
;   Report CMSVLIB version number when /VERBOSE is set, 22 Nov 2009,
;      CM
;   Change to accomodate lack of GDL functionality when restoring
;      all variables, 22 Nov 2009, CM
;
; $Id: cmrestore.pro,v 1.22 2009/11/22 23:31:00 craigm Exp $
;
;-
; Copyright (C) 2000-2001, 2008, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; This utility function is only called under IDL 4
function arg_present, x
  return, 0
end

pro cmrestore,   filename0, filename=filename1, $
                  p0,  p1,  p2,  p3,  p4,  p5,  p6,  p7,  p8,  p9, $
                 p10, p11, p12, p13, p14, p15, p16, p17, p18, p19, $
                 p20, p21, p22, p23, p24, p25, p26, p27, p28, p29, $
                 verbose=verbose, all=all, restored_objects=restobj, $
                 status=status, varstatus=colstatus, mtimes=mtimes, $
                 names=names, data=data, pass_method=method, $
                 errmsg=errmsg, quiet=quiet, nocatch=nocatch, $
                 relaxed_structure_assignment=relax, version=revision
                  
  forward_function routine_names, ptrarr, ptr_new, handle_create, arg_present

  status = 0
  errmsg = ''
  colstatus = 0 & dummy = temporary(colstatus)  ;; Void out the status

  cmsvlib_version = '<unknown>'
  catch, catcherr
  if catcherr EQ 0 then lib = cmsvlib(/query, version=cmsvlib_version) else lib = 0
  catch, /cancel
  if lib EQ 0 then $
    message, 'ERROR: The CMSVLIB library must be in your IDL path.'

  revision = '$Revision: 1.22 $'
  ;; Extract the version number
  revision = stregex(revision,'\$'+'Revision: *([0-9.]+) *'+'\$',/extract,/sub)
  revision = revision(1)

  if keyword_set(verbose) then begin
     message, /info, 'CMRESTORE version '+revision, traceback=0
     message, /info, 'CMSV Library version '+cmsvlib_version(0), traceback=0
  endif

  if NOT keyword_set(nocatch) then on_error, 2
  kall = 0                      ;; NOTE: Ignoring ALL keyword!!

  n_par = n_params()
  nnames = n_elements(names)
  ver = double(!version.release)
  if n_elements(filename0) EQ 0 AND n_elements(filename1) EQ 0 then begin
      message, 'USAGE: CMRESTORE, filename, VAR1, VAR2, ...', /info
      return
  end
  ;; Now n_par refers to the number of positional variables (ie,
  ;; filename excluded)
  n_par = n_par - 1

  ;; Default processing
  if n_elements(filename0) GT 0 then filename = strtrim(filename0(0),2) $
  else                               filename = strtrim(filename1(0),2)

  ;; Input method
  if n_elements(method) EQ 0 then begin
      if n_par GT 0 then meth = 'ARGUMENT' $
      else               meth = 'STORE'
  endif else begin
      meth = strupcase(strtrim(method(0),2))
  endelse
  ;; Trim it down so that people don't have to type too many characters
  meth = strmid(meth, 0, 3)

  ;; Error checking on input method, depending on IDL version
  if meth EQ 'ARG' AND ver LT 5D AND nnames EQ 0 then begin
      errmsg = ('ERROR: in IDL 4 you cannot pass variables by argument '+ $
                'to CMRESTORE.')
      goto, PRE_CLEANUP
  endif
  ;; Implicit restore of ALL, if no names are provided
  if nnames EQ 0 AND n_par EQ 0 then kall = 1
  ;; GDL is incapable of restoring all variables without them being named.
  DEFSYSV, '!gdl', exists=is_it_gdl
  if is_it_gdl then begin
      if nnames EQ 0 then kall = 1
  endif

  ;; Extract some information about the calling routine
  lev = routine_names(/level)
  vlev = lev - 1

  ;; Note: if the user specified "ALL" then we set NNAMES to zero,
  ;; indicating that the number of variables to be returned is unknown
  ;; at present.
  if kall then nnames = 0L

  if n_par LT 1 AND meth NE 'STO' AND arg_present(data) EQ 0 then begin
      if ver GE 5D OR meth EQ 'ARG' then begin
          errmsg = ('ERROR: A way to return data must be specified.  Pass by'+$
                    ' argument (IDL >= 5), or using the NAMES/DATA keywords.')
          goto, PRE_CLEANUP
      endif
  endif

  ;; ---------------- Establish I/O parameters -------------------
  ;; Upon exit from this block, at least the following variables must
  ;; be set: (a) nvar = number of named variables, (b) vnames = names
  ;; of variables in SAVE file to be restored.
  
  ;; Special case: if keyword ALL is set, then nvar EQ 0, and vnames
  ;; is undefined.  It will be filled in later then.
  if meth EQ 'ARG' then begin
      ;; Now processing that depends on the data passing method.  The
      ;; "argument" method is via positional arguments.

      ;; Extract variables from positional parameters
      if kall EQ 0 then nnames = n_par
      if (kall EQ 0 AND nnames EQ 0) $
        OR (kall AND n_par LE 0) then begin
          errmsg = 'ERROR: Returnable variables must be specified.'
          goto, PRE_CLEANUP
      endif
      lev1 = strtrim(lev-1,2)
      nvar = nnames
      if nvar GT 0 then vnames = strarr(nvar)
      if NOT kall AND ver GE 5D then begin
          for i = 0L, nvar-1 do $
            dummy = execute('vnames(i) = (routine_names(p'+strtrim(i,2)+ $
                            ',arg_name='+lev1+'))(0)')
      endif
  endif else if meth EQ 'STO' then begin
      ;; This information is used to determine whether the variable
      ;; already exists in the caller.  If it doesn't, and we are in
      ;; IDL 5.2 or earlier, then we can't save it.
      cnames = strupcase(strtrim(routine_names(variables=vlev),2))

      nvar = nnames
      if nvar GT 0 then vnames = strarr(nvar)
      
  endif else begin

      ;; Instead of passing the data via positional parameters, they
      ;; can be set through the DATA keyword, but even there this can
      ;; be accomplished with several means: via pointers, via
      ;; handles, or using a structure.
      
      ;; Clear DATA in preparation for restore operation
      data = 0 & dummy = temporary(data)
      nvar = nnames
      if nvar GT 0 then vnames = strarr(nvar)

      if meth EQ 'POI' then begin               ;; POINTER TYPE
          ;; Construct an array of null pointers to start with
          if nvar GT 0 then data = ptrarr(nvar)
      endif else if meth EQ 'HAN' then begin     ;; HANDLE TYPE
          ;; Construct an array of invalid handles to start with
          if nvar GT 0 then data = lonarr(nvar)-1L
      endif else if meth EQ 'STR' then begin
          ;; Do nothing
      endif else begin
          errmsg = 'ERROR: PASS_METHOD must be one of ARGUMENT, POINTER, '+$
            'HANDLE or STRUCT'
          PRE_CLEANUP:
          status = 0
          if NOT keyword_set(quiet) then message, errmsg, /info
          return
      endelse
  endelse

  if kall EQ 0 then begin
      if nvar LE 0 then begin
          errmsg = 'ERROR: no variable names were specified'
          goto, PRE_CLEANUP
      endif else begin
          colstatus = lonarr(nvar)
      endelse
  endif

  ;; User-renamed variables.  These names will override any names
  ;; specified in positional parameters.
  if n_elements(names) GT 0 AND NOT kall then begin
      sz = size(names)
      if sz(sz(0)+1) NE 7 then begin
          errmsg = 'ERROR: NAMES must be a string array'
          goto, PRE_CLEANUP
      endif
      vnames(0) = strtrim(strupcase(names(*)),2)
  endif

  ;; Open the save file
  get_lun, unit
  cmsv_open, unit, filename, pp, access='R', status=status, errmsg=errmsg
  if status EQ 0 then goto, CLEANUP
  if keyword_set(verbose) then $
    message, 'Portable (XDR) SAVE/RESTORE file.', /info, traceback=0

  pp0 = pp  ;; Block pointer
  ivar = 0L ;; Number of variables that have been read successfully
  if n_elements(vnames) GT 0 then $
    found = lonarr(n_elements(vnames))

  ptr_index   = [0L]
  ptr_offsets = [0L]
  if ver GE 5D then ptr_data = [ptr_new()] $
  else              ptr_data = [0L]

  ;; Now begin the processing
  repeat begin
      ;; Read block from SAVE file
      bn = ''
      point_lun, unit, pp
      block = 0 & dummy = temporary(block)
      cmsv_rrec, block, pp1, bdata, unit=unit, next_block=pnext, /init, $
        block_type=bt, block_name=bn, status=status, errmsg=errmsg, offset=pp,$
        promote64=promote64
      if status EQ 0 then goto, CLEANUP
      eb = (bn EQ 'END_MARKER')

      ;; Examine each block type  -----

      errmsg = ''
      jfind = -1L
      case bn of 

          ;; Promote record header to 64-bits (compatibility)
          'PROMOTE64': if keyword_set(verbose) then begin
              message, 'File contains 64-bit offsets.', /info, traceback=0
          endif

          ;; Read time stamp record
          'TIMESTAMP': if keyword_set(verbose) then begin
              stamp = bdata
              message, 'Save file written by '+stamp.save_user+'@'+ $
                stamp.save_host+', '+stamp.save_date, /info, traceback=0
          endif
          
          ;; Read version record
          'VERSION': if keyword_set(verbose) then begin
              vers = bdata
              message, ('IDL version '+vers.release+' ('+vers.os+ $
                        ', '+vers.arch+')'), /info, traceback=0
              message, 'File format revision: '+ $
                strtrim(vers.format_version,2), /info, traceback=0
          endif

          ;; Read heap index record
          'HEAP_INDEX': begin
              ii = bdata
              ptr_index   = [ptr_index, ii]
              ptr_offsets = [ptr_offsets, ii*0L]
              if ver GE 5D then $
                ptr_data    = [ptr_data, ptrarr(n_elements(ii))]
          end

          ;; Read heap data - just store a file pointer for later
          ;;                  referral
          'HEAP_DATA': begin
              p2 = pp1
              cmsv_rvtype, block, pp1, vindex, /heap, unit=unit, $
                status=st1, errmsg=errmsg
              if st1 EQ 0 then goto, NEXT_BLOCK

              ;; VINDEX will be the heap variable number.  Once we
              ;; know this we can put the file offset into
              vindex = floor(vindex(0))
              wh = where(ptr_index EQ vindex, ct)
              if ct EQ 0 then goto, NEXT_BLOCK
              ptr_offsets(wh(0)) = pp + p2  ;; block address + offset
          end              

          ;; Read variable data, and store for return to caller
          'VARIABLE': begin
              ;; Read variable type
              cmsv_rvtype, block, pp1, vn, sz1, unit=unit, status=st1, $
                template=tpp1, errmsg=err1
              if vn EQ '' OR st1 EQ 0 then goto, NEXT_BLOCK
              if kall EQ 0 then begin
                  jfind = (where(vn EQ vnames, ct))(0)
                  if ct EQ 0 then goto, NEXT_BLOCK
                  found(jfind) = 1
              endif
              
              ;; Read variable data
              cmsv_rdata, block, pp1, sz1, val, template=tpp1, status=st1, $
                unit=unit, errmsg=errmsg, ptr_offsets=ptr_offsets, $
                ptr_index=ptr_index, ptr_data=ptr_data
              if st1 EQ 0 then goto, NEXT_BLOCK
              if sz1(0) GT 0 then arr = 1 else arr = 0
              if arr then begin
                  ;; If an array then reform to be sure dimensions are right
                  dims = sz1(1:sz1(0))
                  val = reform(val, dims, /overwrite)
              endif
              
              if kall then begin
                  ;; With ALL, we extend the vector at each variable
                  jfind = ivar & ii = strtrim(jfind,2)
                  if ivar EQ 0 then begin
                      anames = [vn]
                      colstatus = [0L]
                  endif else begin
                      anames = [anames, vn]
                      colstatus = [colstatus, 0L]
                  endelse
              endif
              
              ;; Now send the data to output, depending on the method
              case meth of 
                  'ARG': begin
                      ;; Position dependent parameter
                      if jfind GE n_par then goto, NEXT_BLOCK
                      ii = strtrim(jfind,2)
                      if arr EQ 0 then begin
                          dummy = execute('p'+ii+' = temporary(val)') 
                      endif else begin
                          dummy = execute('p'+ii+' = reform(val, dims, '+ $
                                          '/overwrite)')
                      endelse
                      if dummy EQ 0 then goto, NEXT_BLOCK
                  end
                  'STO': begin
                      ;; Store the data in caller.  Check for IDL 5.3
                      ;; compatibility.
                      jfind1 = where(vn EQ cnames, ct1)
                      if ver LT 5.3D AND jfind1(0) EQ -1 then begin
                          if keyword_set(quiet) EQ 0 then begin
                              message, 'WARNING: could not create variable '+$
                                vn+' in calling routine.', /info, traceback=0
                          endif
                          goto, NEXT_BLOCK
                      endif
                      dummy = routine_names(vn, val, store=vlev)
                  end
                  'POI': begin
                      ;; Pointer to data
                      if kall then begin
                          if ivar EQ 0 then data = ptrarr(1) $
                          else data = [data, ptr_new()]
                      endif
                      data(jfind) = ptr_new(val)
                  end
                  'HAN': begin
                      ;; Handle to data
                      if kall then begin
                          if ivar EQ 0 then data = [-1L] $
                          else data = [data, -1L]
                      endif
                      data(jfind) = handle_create(value=val, /no_copy)
                  end
                  'STR': begin
                      ;; Add data to structure
                      if n_elements(sdata) EQ 0 then $
                        sdata = create_struct(vn, val) $
                      else $
                        sdata = create_struct(sdata, vn, val)
                  end
              endcase
              
              colstatus(jfind) = 1
              if kall then ivar = ivar + 1
          end


          ELSE: dummy = 1
      endcase

      NEXT_BLOCK:
      if NOT keyword_set(quiet) then begin
          if errmsg NE '' then $
            message, errmsg, /info
          if keyword_set(verbose) AND jfind GE 0 then begin
              if colstatus(jfind) EQ 1 then $
                message, 'Restored variable: '+vn+'.', /info, traceback=0 $
              else $
                message, 'Unable to restore variable: '+vn+'.', /info, $
                traceback=0
          endif
      endif
      ;; Advance to next block
      if pp NE pnext then begin
          pp = pnext 
      endif else begin
          status = 0
          errmsg = 'ERROR: internal inconsistency'
      endelse
  endrep until bn EQ 'END_MARKER' OR status EQ 0

  ;; Clean up
  free_lun, unit

  DONE_RESTORE:
  if meth EQ 'STR' then begin
      ;; Put new struct data on output
      data = 0 & dummy = temporary(data)
      if n_elements(sdata) GT 0 then data = temporary(sdata)
  endif
  if kall then begin
      names = 0 & dummy = temporary(names)
      if n_elements(anames) GT 0 then names = anames
  endif

  if n_elements(found) GT 0 then begin
      wh = where(found EQ 0, ct)
      fmt = '(A,'+strtrim(ct,2)+'(A,:," "),".")'
      if ct GT 0 then begin
          errmsg = string("WARNING: the following variables were not found: ",$
                          vnames(wh), format=fmt)+'.'
          if NOT keyword_set(quiet) OR keyword_set(verbose) then $
            message, errmsg, /info, traceback=0
      endif
  endif

  if total(colstatus) GT 0 then begin
      status = 1
  endif else begin
      status = 0
      errmsg = 'ERROR: No variables were restored.'
      if meth EQ 'STO' AND ver LT 5.3D then begin
          errmsg = errmsg + '  NOTE: In IDL 5.2 and earlier the variable '+$
            'must first be defined by the caller in order to use the '+$
            '"implicit" restore technique.'
          message, errmsg, /info, traceback=0
      endif
  endelse

  return

  ;; 
  ;; Error handling routine, outside the normal call flow
  CLEANUP:
  catch, /cancel
  if n_elements(unit) GT 0 then free_lun, unit
  status = 0
  if errmsg NE '' AND NOT keyword_set(quiet) then message, errmsg, /info

  return
end

;+
; NAME:
;   CMSAVE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Save IDL variables to a file.  (IDL v5 and greater)
;
; CALLING SEQUENCE: (various)
;   CMSAVE, var1, var2, ..., FILENAME=filename [, NAMES=names]
;   CMSAVE, DATA=pointers, NAMES=names, FILENAME=filename
;   CMSAVE, DATA=handles, NAMES=names,  FILENAME=filename
;   CMSAVE, DATA=structure,             FILENAME=filename
;   
; DESCRIPTION: 
;
;   CMSAVE is a replacement for the built-in IDL procedure SAVE, with
;   more flexibility and increased capabilities.
;
;   CMSAVE produces output files that are compatible with the standard
;   save format of IDL versions 4 and 5 (and perhaps greater).
;   Variables may be restored by using either the built-in procedure
;   RESTORE, or CMRESTORE.  The CMSV utility library must be installed
;   in your IDL path to use CMSAVE and CMRESTORE.
;
;   The primary advantages to CMSAVE are the ability to append
;   additional variables to an existing SAVE file, and several
;   flexible ways to pass the data and variable names to be saved.
;   CMSAVE also attempts to run on all IDL versions.
;
;   To append variables to an existing file, simply specify the APPEND
;   keyword, and the filename of an existing writable SAVE file.
;   Variables will be appended to the end of the file.  It is possible
;   to append a variable with the same name as an existing variable in
;   a file.  Both data values are stored in the file.  However the
;   results upon restore are undefined.  There is also a limitation
;   that only one series of heap values -- pointed-to data -- may be
;   saved in a file.
;
;   By the normal convention of the built-in SAVE command, both the
;   data and variable names to be saved are passed as parameters on
;   the command line.  Each parameter must be a named variable; both
;   the name and value are saved.
;
;   This convention may be used in invoking CMSAVE as well.  However,
;   in addition to passing the data by positional parameter, the user
;   can pass the data using the DATA keyword.  If the DATA keyword is
;   used, then an array of pointers or handles may be passed, or a
;   structure of values may be passed.  (see below)  If both are
;   passed, then the positional parameters take precedence.
;
;   It is also possible to explicitly rename the saved variables: the
;   saved name does not need to be the name of the named variable.
;   Use the NAMES keyword to override the default name.  By default
;   the name is drawn from any named variables, or from the structure
;   tag names if the DATA keyword is used with a structure.  The NAMES
;   keyword takes precedence over these values.  NOTE: Values passed
;   by pointer or handle are not named by default, and so will not be
;   saved unless the NAMES keyword is used.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; COMPATIBILITY:
;
;   -- File Format --
;   Files written by CMSAVE should be readable with all known versions
;   of IDL at the time of this writing (version 4 - version 5.4).  It
;   is expected that this compatibility will persist.
;
;   CMSAVE cannot write objects, compressed files, or data sets larger
;   than 2 gigabytes.
;
;   Data types available in newer versions of IDL, such as pointers
;   and long integers, will not be readable in older versions of IDL
;   which do not have those data types.
;
;   -- Calling Interface --
;
;   For the most part, all capabilities of CMSAVE are available to the
;   user.  However, it should be noted that passing variables by
;   positional parameter is not available under IDL 4, unless NAMES is
;   used to name the variables explicitly.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; INPUTS:
;
;   VAR{i} - The variables to be saved.  By default the save name is
;            taken from the named variables that are passed.  These
;            default names can be overridden by using the NAMES
;            keyword.
;
;            Variables can also be specified by passing an array of
;            handles or pointers in the DATA keyword.
;
;            If no variables are passed as positional parameters or
;            using DATA, then CMSAVE will assume that *all* variables
;            at the caller's level should be saved (this is similar
;            behavior to the built-in SAVE routine).  Note that system
;            variables cannot be saved with CMSAVE.
;
; KEYWORDS:
;
;   ALL - for compatibility with the built-in SAVE routine.  Ignored.
;         Note that CMSAVE cannot save system variables.
;
;   FILENAME - the name of the output file.
;              Default: 'cmsave.sav'
;
;   DATA - A list of data elements to be saved to the output file.
;          The data elements can be one of the following.  The means
;          of extracting the data, and the method of naming each
;          variable, are also indicated.
;
;            * An array of pointers to the variables
;                    Data: pointed-to value     Name: from NAMES keyword
;            * An array of handles to the variables
;                    Data: pointed-to value     Name: from NAMES keyword
;            * A 1-element structure containing data to be saved.
;                    Data: tag value            Name: tag name
;
;          Data values are saved one by one, using the appropriate
;          name.  Note that any variables passed as positional
;          parameters will cause the DATA keyword to be ignored.
;
;          The calling routine is responsible for deallocating any
;          pointer or handle resources.
;
;   COMPATIBILITY - a string, which describes the format to be used in
;          the output file.  Possible values are:
;
;                  'IDL4' - format of IDL version 4;
;                  'IDL5' - format of IDL versions 5.0-5.3;
;                  'IDL6' - not supported yet, for versions 5.4-above;
;                  'RIVAL1' - same as 'IDL5', plus a directory entry is
;                            written to the file.
;           Note that files written in IDL5 format may still be
;           readable by IDL v.4.
;           Default: 'IDL5'
;
;   NAMES - a string array, giving the names for each variable.  
;
;           If the data are passed by positional parameters, the names
;           are assigned according to the position of the parameter in
;           the procedure call.  This can be especially useful to
;           rename local variables, and to give names to expressions.
;
;           If the data are passed by an array of pointers or handles,
;           then the names are assigned according to the position of
;           the data in the array.  In this case there is no other way
;           to supply the variable name.  NAMES is required.
;
;           If the data are passed in a structure, then the names are
;           assigned according to the position of the data in the
;           structure.  The NAMES keyword values override the tag
;           names.
;
;   APPEND - if set, then the specified variables are appended to an
;            existing file.  
;
;            Repeated variables will not cause an error, however they
;            may not be restored properly using the built-in RESTORE
;            procedure.  It may also not be permitted to append
;            variables that contain heap pointers, to a save file
;            which already contains heap data.
;
;   STATUS - upon return, an integer indicating the status of the
;            operation.  A value of 1 indicates success, while 0
;            indicates failure.  A failure condition does not
;            necessarily indicate that an individual variable could
;            not be written; use the VARSTATUS keyword to detect such
;            situations.
;
;   VARSTATUS - upon return, an integer array indicating the status of
;               the save operation for each variable.  A value of 1 at
;               position i in the array indicates success for the ith
;               variable, while a value of 0 indicates failure.
;
;   ERRMSG - upon return, a string indicating the status of the
;            operation.  The empty string indicates success, while a
;            non-empty string indicates failure and describes the
;            error condition.
;
;   QUIET - if set, then the error message is returned to the calling
;           routine.  By default an error condition causes execution
;           to stop and the message to be printed on the console.
;
;   VERBOSE - if set, then a short message is printed for each
;             variable.
;
;   XDR - for compatibility with the built-in SAVE routine.  Ignored.
;
; EXAMPLE:
;
;   CMSAVE, VAR1, VAR2, FILENAME='test.sav'
;   CMSAVE, VAR1, VAR2, FILENAME='test.sav', NAMES=['A','B']
;
;     Save the data in VAR1 and VAR2 to the file test.sav.  In the
;     first case the saved variable names will be VAR1 and VAR2.  In
;     the second case the saved variable names will be A and B.
;
;   POINTERS = [ptr_new(VAR1), ptr_new(VAR2)]
;   CMSAVE, DATA=POINTERS, NAMES=['A','B'], FILENAME='test.sav'
;
;     Save the data in VAR1 and VAR2 to the file test.sav.  The saved
;     variable names will be A and B.  Data are passed by pointer.
;
;   STRUCTURE = {A: VAR1, B: VAR2}
;   CMSAVE, DATA=STRUCTURE, FILENAME='test.sav'
;
;     Save the data in VAR1 and VAR2 to the file test.sav.  The saved
;     variable names will be A and B.  Data are passed by structure.
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 14 May 2000
;   Documented, 22 Sep 2000
;   Made "more" compatible with SAVE; additional documentation, 11 Jan
;     2001, CM
;   Make version checks with correct precision, 19 Jul 2001, CM
;   Added notification about RSI License, 13 May 2002, CM
;
; $Id: cmsave.pro,v 1.16 2009/11/22 23:26:19 craigm Exp $
;
;-
; Copyright (C) 2000-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Undocumented
;; MTIMES
;; PASS_METHOD
;; NOCATCH

pro cmsave,   p0,  p1,  p2,  p3,  p4,  p5,  p6,  p7,  p8,  p9, $
             p10, p11, p12, p13, p14, p15, p16, p17, p18, p19, $
             p20, p21, p22, p23, p24, p25, p26, p27, p28, p29, $
             filename=filename0, verbose=verbose, xdr=xdr, $
             compatible=compat0, append=append, all=all, $
             status=status, varstatus=colstatus, mtimes=mtimes, $
             names=names, data=data, pass_method=method, $
             errmsg=errmsg, quiet=quiet, nocatch=nocatch, useunit=useunit, $
             version=revision

  forward_function routine_names, ptr_valid, handle_info

  status = 0
  errmsg = ''
  colstatus = 0 & dummy = temporary(colstatus)  ;; Void out the status

  cmsvlib_version = '<unknown>'
  catch, catcherr
  if catcherr EQ 0 then lib = cmsvlib(/query, version=cmsvlib_version) else lib = 0
  catch, /cancel
  if lib EQ 0 then $
    message, 'ERROR: The CMSVLIB library must be in your IDL path.'

  revision = '$Revision: 1.16 $'
  ;; Extract the version number
  revision = stregex(revision,'\$'+'Revision: *([0-9.]+) *'+'\$',/extract,/sub)
  revision = revision(1)

  if keyword_set(verbose) then begin
     message, /info, 'CMSAVE version '+revision, traceback=0
     message, /info, 'CMSV Library version '+cmsvlib_version(0), traceback=0
  endif

  if NOT keyword_set(nocatch) then on_error, 2

  n_par = n_params()
  ver   = double(!version.release)
  kall  = 0                        ;; NOTE: Ignoring ALL keywod!!
  if n_elements(filename0) EQ 0 then filename0 = 'cmsave.sav'
  filename = strtrim(filename0(0),2)

  if n_elements(compat0) EQ 0 then compat0 = 'IDL5'
  compat = strupcase(strtrim(compat0(0),2))
  lev = routine_names(/level)
  szd = size(data)
  ndata = n_elements(data)
  nnames = n_elements(names)
  
  ;; By default, if no arguments are specified (and no data) then, then
  ;; all of the data in the caller is saved.
  if n_par EQ 0 AND ndata EQ 0 then kall = 1
  if n_par EQ 0 AND kall EQ 0 AND nnames EQ 0 AND ndata EQ 0 then begin
      NO_VARS:
      status = 1
      errmsg = 'WARNING: no variables were specified; '+filename+' not created'
      if NOT keyword_set(quiet) then message, errmsg, /info
      return
  endif

  if kall then begin
      ;; Extract variables from calling procedure
      vlev = lev - 1
      vnames = routine_names(variables=vlev)
      fnames = 'routine_names("'+vnames+'",fetch=vlev)'
      nvar = n_elements(vnames)
      atype = 'FETCH'

  endif else if n_par EQ 0 AND nnames GT 0 then begin
      ;; Extract named variables from the calling procedure
      vlev = lev - 1
      vnames = strtrim(names,2)
      fnames = 'routine_names("'+vnames+'",fetch=vlev)'
      nvar = nnames
      atype = 'FETCH'
      
  endif else if n_par GT 0 then begin
      ;; Extract variables from positional parameters
      vlev = lev
      lev1 = strtrim(lev-1,2)
      nvar = n_par
      fnames = 'p'+strtrim(indgen(nvar),2)
      vnames = strarr(nvar)
      if ver GE 5D then $
        for i = 0L, nvar-1 do $
        dummy = execute('vnames(i) = (routine_names('+fnames(i)+ $
                        ',arg_name='+lev1+'))(0)')
      atype = 'FETCH'

  endif else begin
      ;; Extract variables from DATA
      vlev = lev
      tp = szd(szd(0)+1)
      if tp EQ 10 then begin               ;; POINTER TYPE
          nvar = ndata
          fnames = strarr(nvar) & vnames = fnames
          wh = where(ptr_valid(data) EQ 1, ct)
          if ct GT 0 then fnames(wh) = '*(data['+strtrim(wh,2)+'])'
          atype = 'POINTER'
      endif else if tp EQ 3 then begin     ;; HANDLE TYPE
          nvar = ndata
          fnames = strarr(nvar) & vnames = fnames
          wh = where(handle_info(data) EQ 1, ct)
          if ct GT 0 then $
            fnames(wh) = 'cmsave_handle_value(data('+strtrim(wh,2)+'))'
          atype = 'HANDLE'
      endif else if tp EQ 8 then begin
          nvar = n_tags(data(0))
          stsize = tagsize(data(0), n_tags=nvar, tag_names=vnames)
          fnames = 'data(0).'+vnames
          atype = 'STRUCT'
      endif else begin
          errmsg = 'ERROR: keyword DATA must be a pointer array or structure'
          status = 0
          return
      endelse
  endelse

  if nvar LE 0 then goto, NO_VARS
  colstatus = lonarr(nvar)

  ;; User-renamed variables
  if n_elements(names) GT 0 then begin
      sz = size(names)
      if sz(sz(0)+1) NE 7 then begin
          errmsg = 'ERROR: NAMES must be a string array'
          status = 0
          return
      endif
      vnames(0) = strtrim(strupcase(names(*)),2)
  endif

  ;; Check for variables with missing names.  By default don't do
  ;; anything, unless all the variables do not have names, or if we
  ;; are using IDL 4, which cannot accept parameters from the command
  ;; line.
  wh = where(vnames EQ '', ct)
  if ct EQ nvar then begin
      errmsg = ('ERROR: no variables have names (are you using IDL 4 or' + $
                ' forget the NAMES keyword?)')
      status = 0
      return
  endif
  if ver LT 5D AND ct GT 0 then begin
      if keyword_set(verbose) then $
        message, ('WARNING: in IDL 4 you cannot pass variables by argument '+ $
                  'to CMSAVE.'), /info, traceback=0
  endif

  ;; Collect a summary of pointers
  if ver GE 5D then begin
      cmsv_ptrsum, null, /null
      pheap = null
      pind  = 0L
      
      catcherr = 0
      catch, catcherr
      if catcherr NE 0 then goto, DONE_PTR
      for i = 0L, nvar-1 do begin
          pheap1 = null
          if fnames(i) EQ '' OR $
            execute('cmsv_ptrsum, '+fnames(i)+', pheap1') EQ 0 then $
            goto, DONE_PTR
          if n_elements(pheap1) GT 1 then begin
              pheap = [pheap, pheap1]
              pheap = pheap(uniq(pheap, sort(pheap)))
          endif
          DONE_PTR:
      endfor
      catch, /cancel
  endif else pheap = 0L

  nheap = n_elements(pheap) - 1
  if nheap GT 0 AND compat EQ 'IDL4' then begin
      errmsg = 'ERROR: cannot store pointer data in IDL4 version file'
      status = 0
      return
  endif

  ;; Open output file
  if keyword_set(append) then access='RW' else access='W'
  cmsv_open, unit, filename, off0, access=access, /get_lun, status=status, $
    errmsg=errmsg, compat=compat
  if status EQ 0 then begin
      if keyword_set(quiet) EQ 0 then message, errmsg, traceback=0
      return
  endif
  pp = 0L

  has_heap = 0
  nauxvars = 0L
  if keyword_set(append) then begin
      ;; Scan through input file until we reach the end-of-file block
      bn = ''
      while status EQ 1 AND bn NE 'END_MARKER' do begin
          point_lun, unit, off0
          block = 0 & dummy = temporary(block)
          cmsv_rrec, block, pp, unit=unit, next_block=pnext, /init, $
            block_type=bt, block_name=bn, status=status, errmsg=errmsg, $
            promote64=promote64
          if status EQ 0 then goto, CLEANUP
          if bn EQ 'HEAP_INDEX' then has_heap = 1
          if bn EQ 'VARIABLE' AND status EQ 1 then begin
              cmsv_rvtype, block, pp, vn, sz1, unit=unit, status=st1, $
                template=tp1, errmsg=err1
              if strmid(vn,0,12) EQ '_CMSAVE_DIR_' then $
                nauxvars = nauxvars + 1
          endif
          if status EQ 1 AND bn NE 'END_MARKER' then off0 = pnext
      endwhile

      if bn NE 'END_MARKER' then goto, CLEANUP
      point_lun, unit, off0
      
  endif else begin
      ;; Create the file and append the start record blocks
      if keyword_set(verbose) then $
        message, 'Portable (XDR) SAVE/RESTORE file.', /info

      ;; both timestamp and version information
      cmsv_wrec, block, pp, block_name='TIMESTAMP', offset=off0, $
        status=status, errmsg=errmsg
      if (status NE 0) AND (compat NE 'IDL4') then $
        cmsv_wrec, block, pp, block_name='VERSION', offset=off0, $
        status=status, errmsg=errmsg, compat=compat
      if (status EQ 0) OR (pp EQ 0) then goto, CLEANUP

      writeu, unit, block(0:pp-1)
      off0 = off0 + pp
  endelse

  if nheap GT 0 AND keyword_set(append) AND has_heap AND $
    strmid(compat,0,3) EQ 'IDL' then begin
      errmsg = 'ERROR: cannot APPEND data containing POINTER type'
      goto, CLEANUP
  endif

  pp = 0L
  block = 0 & dummy = temporary(block)

  if nheap GT 0 then begin
      pind = lindgen(nheap) + 1
      pheap = pheap(1:nheap)
      cmsv_wrec, block, pp, pind, block_name='HEAP_INDEX', offset=off0, $
        status=status, errmsg=errmsg, unit=unit1
      if status NE 1 then goto, CLEANUP
  endif 
  if pp GT 0 then writeu, unit, block(0:pp-1)
  off0 = off0 + pp

  if keyword_set(useunit) then $
    unit1 = unit

  pp = 0L
  block = 0 & dummy = temporary(block)
  init = 1 & err1 = '' & saved = 0
  erri = strarr(nvar+nheap)

  catcherr = 0 & caught = 0
  if NOT keyword_set(nocatch) then catch, catcherr
  if catcherr NE 0 then begin
      caught = caught + 1
      goto, DONE_VAR
  endif

  for i = 0L, nheap+nvar-1 do begin
      saved = 0
      nelem = 0
      j = i - nheap

      if j LT 0 then begin
          ;; Extract heap value
          bn = 'HEAP_DATA'
          vname = long(pind(i))
          dummy = execute('sz = size(*pheap(i))')
          if sz(sz(0)+1) EQ 0 then goto, DONE_VAR
          dummy = execute('var = *pheap(i)')

      endif else begin
          ;; Extract variable value
          bn = 'VARIABLE'
          fname = fnames(j)
          vname = vnames(j)
          
          sz = 0 & var = 0 & dummy = temporary(var)
          if fname EQ '' then begin
              NO_NAME:
              err1 = 'WARNING: un-named expression(s) not written'
              goto, DONE_VAR
          endif

          if execute('sz = size('+fname+')') EQ 0 then goto, DONE_VAR
          if sz(sz(0)+1) EQ 0 OR sz(sz(0)+2) EQ 0 then goto, DONE_VAR
          if execute('var = '+fname) EQ 0         then goto, DONE_VAR

          ;; For data taken from the structure then we may need to
          ;; pull out a more accurate array type.
          if atype EQ 'STRUCT' then sz = stsize(*,j)
          sz = sz(0:sz(0)+2)
          
          nelem = n_elements(var)
          if nelem EQ 0  then goto, DONE_VAR
          if vname EQ '' then goto, DONE_VAR
      endelse

      ;; Stupid dimensions can be reformed just by assignment.  This
      ;; will catch and reform the variable.
      if (sz(0) GT 0) AND (n_elements(size(var)) NE n_elements(sz)) then $
        var = reform([var], sz(1:sz(0)), /overwrite)
      sz = size(var)
 
      ;; Write data to a block in memory
      off1 = pp
      cmsv_wrec, block, pp, var, vname, block_name=bn, offset=off0, $
        ptr_index=pind, ptr_data=pheap, init=init, unit=unit1, $
        status=status, errmsg=errmsg
      init = 0
      if status EQ 0 then goto, CLEANUP
      saved = 1

      DONE_VAR:
      ;; A tricky business, this error catching...
      if caught GT 1 then begin
          errmsg = 'ERROR: an internal error occurred'
          goto, CLEANUP
      endif
      if caught GT 0 then begin
          err1 = errmsg
      endif

      ;; If we have accumulated enough data, write to file
      if (pp GT 32768L) OR ((i EQ nheap+nvar-1) AND pp GT 0) then begin
          writeu, unit, block(0:pp-1)
          block = 0 & dummy = temporary(block)
          init = 1
          off0 = off0 + pp
          pp = 0L
      endif
      if keyword_set(useunit) AND pp EQ 0 then $
        point_lun, -unit, off0

      ;; Print some diagnostic messages
      if j GE 0 then begin
          colstatus(j) = saved
          if keyword_set(verbose) AND saved then $
            erri(i) = 'Saved variable: '+vname+'.'
          if saved EQ 0 then begin
              if err1 NE '' then $
                erri(i) = err1 $
              else if nelem EQ 0 then $
                erri(i) = 'Undefined item not saved: '+vnames(j)+'.' $
              else begin
                  erri(i) = ('Expression must be named variable: <'+$
                             helpform('', var, /short)+'>')
                  if ver LT 5D then $
                    erri(i) = erri(i) + ' - use NAMES keyword under IDL4'
              endelse
          endif
      endif else begin
          if keyword_set(verbose) AND saved then $
            erri(i) = ('Saved heap value: <'+ $
                       helpform('', var, /short)+'>')
      endelse

      caught = 0
  endfor
  catch, /cancel
  wh = where(erri NE '', ct)
  if ct GT 0 then begin
      if NOT keyword_set(quiet) then for i = 0L, ct-1 do $
        message, erri(wh(i)), /info
      fmt = '('+strtrim(ct,2)+'(A,:))'
      if ct GT 1 then erri(wh(1:*)) = erri(wh(1:*)) + ';'
      errmsg = string(erri(wh), format=fmt)
  endif

  if pp GT 0 then writeu, unit, (temporary(block))(0:pp-1)
  off0 = off0 + pp

  pp = 0L & off1 = 0L
  ;; Write a set of auxiliary directory information
  whgood = where(colstatus NE 0, ngoodvars)
  if ngoodvars GT 0 AND strmid(compat,0,5) EQ 'RIVAL' then begin
      ;; Construct a unique name for the auxiliary directory
      nauxvars = nauxvars + 1
      fname = filename
      i = (rstrpos(fname,'/') > rstrpos(fname,'\') > rstrpos(fname,':') > $
           rstrpos(fname,';') > 0L)
      fname = byte(strmid(fname, i, strlen(fname)))
      i = strpos(fname, '.')
      if i GT 0 then fname = strupcase(strmid(fname, 0, i))
      bb = byte(fname)
      wh = where(bb LT (byte('A'))(0) OR bb GT (byte('Z'))(0), ct)
      if ct GT 0 then bb(wh) = 32b
      fname = strcompress(string(bb), /remove_all)
      if strlen(fname) EQ 0 then fname = 'FILE'
      
      ;; Whew, we got a name!  Now create the data for the directory
      auxvname = string(fname,nauxvars, $
                        format='("_CMSAVE_DIR_",A0,"_",I2.2)')
      auxvdata = replicate({variable:'', mtime:systime(1)}, ngoodvars)
      auxvdata.variable = vnames(whgood)
      if n_elements(mtimes) GT 0 then $
        auxvdata.mtime(0) = double(mtimes(whgood(0:n_elements(mtimes)-1)))
      auxsz = size(auxvdata)

      ;; Write out directory data
      cmsv_wrec, block, pp, auxvdata, auxvname, block_name='VARIABLE', $
        offset=off0, status=status, errmsg=errmsg, unit=unit1
  endif
  ;; Write end marker
  cmsv_wrec, block, pp, block_name='END_MARKER', status=status, offset=off0
  if status EQ 1 AND pp GT 0 then writeu, unit, block(0:pp-1)
  free_lun, unit
  return

  ;; 
  ;; Error handling routine, outside the normal call flow
  CLEANUP:
  catch, /cancel
  free_lun, unit
  status = 0
  if errmsg NE '' AND NOT keyword_set(quiet) then message, errmsg, /info

  return
end
;+
; NAME:
;   CMSAVEDIR
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Display a directory of the variables in an IDL SAVE file.
;
; CALLING SEQUENCE:
;   CMSAVEDIR, filename [, /VERBOSE, /QUIET, ... ]
;   
; DESCRIPTION: 
;
;   CMSAVEDIR will display a listing of the variables and other
;   objects stored in an IDL SAVE file.
;
;   For command-line users the primary function of CMSAVEDIR will be
;   to find out what data is stored in a file and when it was saved.
;   For that, they simply need to type: CMSAVEDIR, 'myfile.sav'
;
;   CMSAVEDIR also offers a number of features for programmers.
;   CMSAVEDIR essentially interrogates the save file and discovers the
;   numbers, names and types of each of the variables stored in the
;   file.  Programmers can use that information to decide whether or
;   how to open a file using the other routines in the CMSVLIB.
;   Various keyword parameters are used return this information, as
;   documented below.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; COMPATIBILITY:
;
;   -- File Format --
;
;   CMSAVEDIR cannot examine compressed save files, or files larger
;   than 2 gigabytes.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; INPUTS:
;
;   FILENAME - a scalar string, the name of the file to be examined.
;
; KEYWORDS:
;
;   VERBOSE - if set, print more detailed information about the input file.
;
;   QUIET - if set, then do not print any output.  Programmers can use
;           this keyword to allow CMSAVEDIR to return information
;           about the file silently.
;
;   STATUS - upon output, 1 for success, otherwise to indicate
;            failure.
;   ERRMSG - upon output, if a failure occurs, a message describing
;            the error condition.
;  
;   N_VARIABLES - upon output, the number of variables in the file.
;   VAR_NAMES - upon output, contains a string array of the names of
;               the variables stored in the file.
;   TYPES - upon output, an 11xN_VARIABLES array containing the SIZE
;           information of each variable in the file.
;
;   N_PRO - upon output, the number of procedures stored in the file.
;   PRO_NAMES - upon output, the names of the procedures stored in the
;               file, as a string array.
;
;   N_FUNCTION - upon output, the number of functions stored in the
;                 file.
;   FUNC_NAMES - upon output, the names of the functions stored in the
;                file, as a string array.
;
;   NAMED_STRUCTS - upon output, a string array listing any named
;                   structures which appear in the SAVE file.
;   NAMED_CLASSES - upon output, a string array listing any named
;                   class structures which appear in the SAVE file.
;
;   TIMESTAMP - upon output, contains the timestamp record information
;               in a structure.  The fields of the structure are:
;                    SAVE_DATE - string - date saved
;                    SAVE_USER - string - user who saved file
;                    SAVE_HOST - string - host name on which file
;                                         saved
;
;   VERSION - upon output, contains the version record information in
;             a structure.  The fields of the structure are:
;                    FORMAT_VERSION - integer - major format version
;                    ARCH    - string - saving host's !VERSION.ARCH
;                    OS      - string - saving host's !VERSION.OS
;                    RELEASE - string - saving host's !VERSION.RELEASE
;
;   NOTICE - upon output, contains any textual notice included within
;            the file.  The fields of the structure are:
;                    TEXT - string - text of the notice
;
;   FORCE - if set, will force CMSAVEDIR to open the file even if it
;           detects a potential incompatibility.
;
; EXAMPLE:
;
;   IDL> cmsavedir, 'int_str_intarr.sav'
;   ** int_str_intarr.sav
;   ** Sun Apr  9 20:28:25 2000 (craigm@beach.gsfc.nasa.gov)
;   ** IDL v5.2 (linux)
;     A               INT       =        0
;     B               STRING    = 'hello'
;     C               INT       = Array[3]
;   ** 3 variable(s), 0 heap value(s) and 0 procedure(s) in 1376 bytes
;
; SEE ALSO:
;
;   CMRESTORE, CMSAVE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Documented, 12 Jan 2001, CM
;   Added USAGE message, 09 Jun 2001, CM
;   Fixed bug in printing common variables, 17 Mar 2002, CM
;   Added notification about RSI License, 13 May 2002, CM
;   Added NOTICE record type, 09 Jun 2003, CM
;   
;
; $Id: cmsavedir.pro,v 1.17 2003/06/28 22:21:07 craigm Exp $
;
;-
; Copyright (C) 2000-2002, 2003, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSET_OP
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Performs an AND, OR, or XOR operation between two sets
;
; CALLING SEQUENCE:
;   SET      = CMSET_OP(A, OP, B)
;
; DESCRIPTION: 
;
;   SET_OP performs three common operations between two sets.  The
;   three supported functions of OP are:
;
;        OP          Meaning
;      'AND' - to find the intersection of A and B;
;      'OR'  - to find the union of A and B;
;      'XOR' - to find the those elements who are members of A or B 
;              but not both;
;
;   Sets as defined here are one dimensional arrays composed of
;   numeric or string types.  Comparisons of equality between elements
;   are done using the IDL EQ operator.
;
;   The complements of either set can be taken as well, by using the
;   NOT1 and NOT2 keywords.  For example, it may be desireable to find
;   the elements in A but not B, or B but not A (they are different!).
;   The following IDL expressions achieve each of those effects:
;
;      SET = CMSET_OP(A, 'AND', /NOT2, B)   ; A but not B
;      SET = CMSET_OP(/NOT1, A, 'AND', B)   ; B but not A
;
;   Note the distinction between NOT1 and NOT2.  NOT1 refers to the
;   first set (A) and NOT2 refers to the second (B).  Their ordered
;   placement in the calling sequence is entirely optional, but the
;   above ordering makes the logical meaning explicit.
;
;   NOT1 and NOT2 can only be set for the 'AND' operator, and never
;   simultaneously.  This is because the results of an operation with
;   'OR' or 'XOR' and any combination of NOTs -- or with 'AND' and
;   both NOTs -- formally cannot produce a defined result.
;
;   The implementation depends on the type of operands.  For integer
;   types, a fast technique using HISTOGRAM is used.  However, this
;   algorithm becomes inefficient when the dynamic range in the data
;   is large.  For those cases, and for other data types, a technique
;   based on SORT() is used.  Thus the compute time should scale
;   roughly as (A+B)*ALOG(A+B) or better, rather than (A*B) for the
;   brute force approach.  For large arrays this is a significant
;   benefit.
;
; INPUTS:
;
;   A, B - the two sets to be operated on.  A one dimensional array of
;          either numeric or string type.  A and B must be of the same
;          type.  Empty sets are permitted, and are either represented
;          as an undefined variable, or by setting EMPTY1 or EMPTY2.
;
;   OP - a string, the operation to be performed.  Must be one of
;        'AND', 'OR' or 'XOR' (lower or mixed case is permitted).
;        Other operations will cause an error message to be produced.
;
; KEYWORDS:
;
;   NOT1, NOT2 - if set and OP is 'AND', then the complement of A (for
;                NOT1) or B (for NOT2) will be used in the operation.
;                NOT1 and NOT2 cannot be set simultaneously.
;
;   EMPTY1, EMPTY2 - if set, then A (for EMPTY1) or B (for EMPTY2) are
;                    assumed to be the empty set.  The actual values
;                    passed as A or B are then ignored.
;
;   INDEX - if set, then return a list of indices instead of the array
;           values themselves.  The "slower" set operations are always
;           performed in this case.
;
;           The indices refer to the *combined* array [A,B].  To
;           clarify, in the following call: I = CMSET_OP(..., /INDEX);
;           returned values from 0 to NA-1 refer to A[I], and values
;           from NA to NA+NB-1 refer to B[I-NA].
;
;   COUNT - upon return, the number of elements in the result set.
;           This is only important when the result set is the empty
;           set, in which case COUNT is set to zero.
;
; RETURNS:
;
;   The resulting set as a one-dimensional array.  The set may be
;   represented by either an array of data values (default), or an
;   array of indices (if INDEX is set).  Duplicate elements, if any,
;   are removed, and element order may not be preserved.
;
;   The empty set is represented as a return value of -1L, and COUNT
;   is set to zero.  Note that the only way to recognize the empty set
;   is to examine COUNT.
;
; SEE ALSO:
;
;   SET_UTILS.PRO by RSI
;
; MODIFICATION HISTORY:
;   Written, CM, 23 Feb 2000
;   Added empty set capability, CM, 25 Feb 2000
;   Documentation clarification, CM 02 Mar 2000
;   Incompatible but more consistent reworking of EMPTY keywords, CM,
;     04 Mar 2000
;   Minor documentation clarifications, CM, 26 Mar 2000
;   Corrected bug in empty_arg special case, CM 06 Apr 2000
;   Add INDEX keyword, CM 31 Jul 2000
;   Clarify INDEX keyword documentation, CM 06 Sep 2000
;   Made INDEX keyword always force SLOW_SET_OP, CM 06 Sep 2000
;   Added CMSET_OP_UNIQ, and ability to select FIRST_UNIQUE or
;     LAST_UNIQUE values, CM, 18 Sep 2000
;   Removed FIRST_UNIQUE and LAST_UNIQUE, and streamlined
;     CMSET_OP_UNIQ until problems with SORT can be understood, CM, 20
;     Sep 2000 (thanks to Ben Tupper)
;   Still trying to get documentation of INDEX and NOT right, CM, 28
;     Sep 2000 (no code changes)
;   Correct bug for AND case, when input sets A and B each only have
;     one unique value, and the values are equal.  CM, 04 Mar 2004
;     (thanks to James B. jbattat at cfa dot harvard dot edu)
;   Add support for the cases where the input data types are mixed,
;      but still compatible; also, attempt to return the same data
;      type that was passed in; CM, 05 Feb 2005
;   Fix bug in type checking (thanks to "marit"), CM, 10 Dec 2005
;   Work around a stupidity in the built-in IDL HISTOGRAM routine,
;      which tries to "help" you by restricting the MIN/MAX to the
;      range of the input variable (thanks to Will Maddox), CM, 16 Jan 2006
;
;  $Id: cmset_op.pro,v 1.6 2006/01/16 19:45:22 craigm Exp $
;
;-
; Copyright (C) 2000, 2004, 2005, 2006, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Utility function, similar to UNIQ, but allowing choice of taking
;; first or last unique element, or non-unique elements.
;; Unfortunately this doesn't work because of implementation dependent
;; versions of the SORT() function.

; function cmset_op_uniq, a, first=first, non=non, count=ct, sort=sortit
;   if n_elements(a) LE 1 then return, 0L
;   sh = (2L*keyword_set(first)-1L)*(-2L*keyword_set(non)+1)
;
;   if keyword_set(sortit) then begin
;       ;; Sort it manually
;       ii = sort(a) & b = a(ii)
;       if keyword_set(non) then wh = where(b EQ shift(b, sh), ct) $
;       else                     wh = where(b NE shift(b, sh), ct)
;       if ct GT 0 then return, ii(wh)
;   endif else begin
;       ;; Use the user's values directly
;       if keyword_set(non) then wh = where(a EQ shift(a, sh), ct) $
;       else                     wh = where(a NE shift(a, sh), ct)
;       if ct GT 0 then return, wh
;   endelse
;
;   if keyword_set(first) then return, 0L else return, n_elements(a)-1
; end

;; Simplified version of CMSET_OP_UNIQ which sorts, and takes the
;; "first" value, whatever that may mean.
function cmset_op_uniq, a
  if n_elements(a) LE 1 then return, 0L

  ii = sort(a) & b = a(ii)
  wh = where(b NE shift(b, +1L), ct)
  if ct GT 0 then return, ii(wh)

  return, 0L
end

function cmset_op, a, op0, b, not1=not1, not2=not2, count=count, $
              empty1=empty1, empty2=empty2, maxarray=ma, index=index

  on_error, 2 ;; return on error
  count = 0L
  index0 = -1L
  ;; Histogram technique is used for array sizes < 32,000 elements
  if n_elements(ma) EQ 0 then ma = 32L*1024L

  ;; Check the number of arguments
  if n_params() LT 3 then begin
      ARG_ERR:
      message, 'USAGE: SET = CMSET_OP(A, OP, B [, COUNT=ct])', /info
      message, '  KEYWORDS: /NOT1, /NOT2, /EMPTY1, /EMPTY2, INDEX', /info
      return, -1L
  endif
  if n_elements(op0) EQ 0 then goto, ARG_ERR
  kind = keyword_set(index)
  fst = 1L
  if keyword_set(last) then fst = 0L
  if keyword_set(first) then fst = 1L

  ;; Check the operation
  sz = size(op0)
  if sz(sz(0)+1) NE 7 then begin
      OP_ERR:
      message, "ERROR: OP must be 'AND', 'OR' or 'XOR'"
      return, -1L
  endif
  op = strupcase(op0)
  if op NE 'AND' AND op NE 'OR' AND op NE 'XOR' then goto, OP_ERR

  ;; Check NOT1 and NOT2
  if keyword_set(not1) AND keyword_set(not2) then begin
      message, "ERROR: NOT1 and NOT2 cannot be set simultaneously"
      return, -1L
  endif
  if (keyword_set(not1) OR keyword_set(not2)) AND $
    (op EQ 'OR' OR op EQ 'XOR') then begin
      message, "ERROR: NOT1 and NOT2 cannot be set with 'OR' or 'XOR'"
      return, -1L
  endif

  ;; Special cases for empty set
  n1 = n_elements(a) & n2 = n_elements(b)
  if keyword_set(empty1) then n1 = 0L
  if keyword_set(empty2) then n2 = 0L
  if n1 EQ 0 OR n2 EQ 0 then begin
      ;; Eliminate duplicates
      if n1 GT 0 then a1 = cmset_op_uniq(a)
      if n2 GT 0 then b1 = cmset_op_uniq(b)
      n1 = n_elements(a1) < n1 & n2 = n_elements(b1) < n2
      case op of 
          'OR': if n1 EQ 0 then goto, RET_A1 else goto, RET_B1
         'XOR': if n1 EQ 0 then goto, RET_B1 else goto, RET_A1
         'AND': begin
             if keyword_set(not1) AND n1 EQ 0 then goto, RET_B1
             if keyword_set(not2) AND n2 EQ 0 then goto, RET_A1
             return, -1L
         end
     endcase
     return, -1L
     RET_A1:
     count = n1
     if kind then begin
         if count GT 0 then return, a1 else return, -1L
     endif
     if count GT 0 then return, a(a1) else return, -1L
     RET_B1:
     count = n2
     if kind then begin
         if count GT 0 then return, b1+n1 else return, -1L
     endif         
     if count GT 0 then return, b(b1) else return, -1L
 endif

  ;; Allow data to have different types, but they must be at least of
  ;; the same "base" type.  That is, you can't combine a number with a
  ;; string, etc.
  ;; basetype 0:undefined 1:real number 6:complex number 7:string
  ;;     8:structure 10:pointer 11:object

  ;;          0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15
  basetype = [0, 1, 1, 1, 1, 1, 6, 7, 8, 6,10,11, 1, 1, 1, 1]

  ;; Check types of operands
  sz1 = size(a) & tp1 = sz1(sz1(0)+1)
  sz2 = size(b) & tp2 = sz2(sz2(0)+1)
  if tp1 LT 0 OR tp1 GE 16 OR tp2 LT 0 OR tp2 GE 16 then begin
      message, 'ERROR: unrecognized data types for operands'
      return, -1
  endif
  if basetype(tp1) NE basetype(tp2) then begin
      TYPE1_ERR:
      message, 'ERROR: both A and B must be of the same type'
      return, -1L
  endif
  if tp1 EQ 8 OR tp1 EQ 10 OR tp1 EQ 11 then begin
      TYPE2_ERR:
      message, 'ERROR: operands must be a numeric or string type'
      return, -1L
  endif

  ;; Now use two different kinds of algorithms: a slower but more
  ;; general algorithm for generic types, and the histogram technique
  ;; for integer types.  Even for integer types, if there is too much
  ;; dynamic range, then the slow method is used.

  if tp1 GE 4 AND tp1 LE 9 then begin
      ;; String and real types, or large int arrays
      SLOW_SET_OP:
      case op of 
          'OR': begin
              uu = [a,b]    ;; OR is simple; just take unique values
              index0 = cmset_op_uniq(uu)
              count = n_elements(index0)
              if kind then return, index0
              return, uu(index0)
          end

          'XOR': begin
              ;; Make ordered list of set union
              ai = cmset_op_uniq(a) & na = n_elements(ai)
              bi = cmset_op_uniq(b) & nb = n_elements(bi)
              ui = [ai, bi+n1]
              uu = [a,b]    & uu = uu(ui) ;; Raw union...
              us = sort(uu) & uu = uu(us) ;; ...and sort
              if kind then ui = ui(temporary(us)) else ui = 0

              ;; Values in one set only will not have duplicates
              wh1 = where(uu NE shift(uu, -1), count1)
              if count1 EQ 0 then return, -1L
              wh = where(wh1(1:*)-wh1 EQ 1, count)
              if wh1(0) EQ 0 then begin
                  if count GT 0 then wh = [-1L, wh] else wh = [-1L]
                  count = n_elements(wh)
              endif
              if count EQ 0 then return, -1
              if kind then return, ui(wh1(wh+1))
              return, uu(wh1(wh+1))
          end

          'AND': begin
              ;; Make ordered list of set union
              ai = cmset_op_uniq(a) & na = n_elements(ai)
              bi = cmset_op_uniq(b) & nb = n_elements(bi)
              ui = [ai, bi+n1]
              uu = [a,b]    & uu = uu(ui)  ;; Raw union...
              us = sort(uu) & uu = uu(us)  ;; ...and sort
              if kind then ui = ui(us) else ui = 0

              if NOT keyword_set(not1) AND NOT keyword_set(not2) then begin

                  ;; Special case: if there are one in each set, and
                  ;; they are equal, then the SHIFT() technique below
                  ;; fails.  Do this one by hand.
                  if na EQ 1 AND nb EQ 1 AND uu(0) EQ uu(1) then begin
                      count = 1L
                      if kind then return, 0L
                      return, [uu(0)]
                  endif

                  ;; If neither "NOT" is set, then find duplicates
                  us = 0L  ;; Save memory
                  wh = where(uu EQ shift(uu, -1L), count) ;; Find non-unique
                  if count EQ 0 then return, -1L
                  ;; This should always select the element from A
                  ;; rather than B (the smaller of the two)
                  if kind then return, (ui(wh) < ui(wh+1))
                  return, uu(wh)
              endif

              ;; For "NOT" cases, we need to identify by set
              ii = make_array(na+nb, value=1b)
              if keyword_set(not1) then ii(0:na-1) = 0
              if keyword_set(not2) then ii(na:*)   = 0
              ii = ii(temporary(us))

              ;; Remove any duplicates
              wh1 = where(uu EQ shift(uu, -1L), count1) ;; Find non-unique
              if count1 GT 0 then ii([wh1, wh1+1]) = 0
              ;; Remainder is the desired set
              wh = where(ii, count)
              if count EQ 0 then return, -1L
              if kind then return, ui(wh)
              return, uu(wh)
          end

      endcase
      return, -1L  ;; DEFAULT CASE
  endif else begin

      ;; INDEX keyword forces the "slow" operation
      if kind then goto, SLOW_SET_OP

      ;; Integer types - use histogram technique if the data range
      ;; is small enough, otherwise use the "slow" technique above
      min1 = min(a, max=max1) & min2 = min(b, max=max2)
      minn = min1 < min2 & maxx = max1 > max2
      nbins = maxx-minn+1
      if (maxx-minn) GT floor(ma(0)) then goto, SLOW_SET_OP

      ;; Work around a stupidity in the built-in IDL HISTOGRAM routine
      if (tp1 EQ 2 OR tp2 EQ 2) AND (minn LT -32768 OR maxx GT 32767) then $
        goto, SLOW_SET_OP

      ;; Following operations create a histogram of the integer values.
      ha = histogram(a, min=minn, max=maxx) < 1
      hb = histogram(b, min=minn, max=maxx) < 1

      ;; Compute NOT cases
      if keyword_set(not1) then ha = 1b - ha  
      if keyword_set(not2) then hb = 1b - hb
      case op of 
          ;; Boolean operations
          'AND': mask = temporary(ha) AND temporary(hb) 
           'OR': mask = temporary(ha)  OR temporary(hb)
          'XOR': mask = temporary(ha) XOR temporary(hb)
      endcase

      wh = where(temporary(mask), count)
      if count EQ 0 then return, -1L
      
      result = temporary(wh+minn)
      if tp1 NE tp2 then return, result
      szr = size(result) & tpr = szr(szr(0)+1)

      ;; Cast to the original type if necessary
      if tpr NE tp1 then begin
          fresult = make_array(n_elements(result), type=tp1)
          fresult(0) = temporary(result)
          result = temporary(fresult)
      endif

      return, result

  endelse

  return, -1L  ;; DEFAULT CASE
end

;     Here is how I did the INDEX stuff with fast histogramming.  It
;     works, but is complicated, so I forced it to go to SLOW_SET_OP.
;     ha = histogram(a, min=minn, max=maxx, reverse=ra) < 1
;     rr = ra(0:nbins) & mask = rr NE rr(1:*) & ra = ra(rr)*mask-1L+mask
;     hb = histogram(b, min=minn, max=maxx, reverse=rb) < 1
;     rr = rb(0:nbins) & mask = rr NE rr(1:*) & rb = rb(rr)*mask-1L+mask
;     ...  AND/OR/XOR NOT masking here ...
;     ra = ra(wh) & rb = rb(wh)
;     return, ra*(ra GE 0) + (rb+n1)*(ra LT 0) ;; is last 'ra' right?

;+
; NAME:
;   CMSV_OPEN
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Open IDL SAVE file for reading or writing
;
; CALLING SEQUENCE:
;   CMSV_OPEN, UNIT, FILENAME, OFFSET, $
;          ACCESS=ACCESS, /FORCE, /GET_LUN, /REOPEN, $
;          COMPATIBILITY=COMPATIBILITY, $
;          STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   CMSV_OPEN opens an IDL SAVE-formatted file for reading or writing.
;   The mode of operation is controlled by the ACCESS keyword, which
;   may be either 'R' for reading, 'W' for writing, or 'RW' for
;   read/write access.
;
;   'R': In the case of reading, the specified file is opened with
;   read-only access, and the first bytes are examined to verify that
;   it is indeed a valid IDL SAVE file.  
;
;   'W': In the case of writing, the specified file is opened with
;   write access, and the initial file signature is written.  
;
;   'RW': In the case of read-write access, the file must already
;   exist as a valid SAVE file.  Users are advised that every time
;   they switch between reading and writing operations, they must use
;   POINT_LUN to flush the file buffers.
;
;   The CMSVLIB routines do not support file sizes greater than 2 GB,
;   nor SAVE files created with the COMPRESS option.
;
;   Upon return, the file pointer is positioned at the start of the
;   first valid SAVE record.  The file offset is returned in OFFSET.
;   The user is responsible for reading or writing the remainder of
;   the file with other library routines.
;
;   The file unit is determined based on the following criteria.  This
;   behavior is similar to the OPEN family of procedures, except for
;   the REOPEN keyword.
;
;     * If REOPEN is set then it is assumed that UNIT is an
;       already-open file, and FILENAME is ignored.  
;
;     * If GET_LUN is set then a file unit is allocated with GET_LUN,
;       and upon success this unit is returned in UNIT.
;
;     * Otherwise it is asssumed that UNIT is a valid but unopened
;       file unit.  Upon successful return, UNIT is opened.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
;
; INPUTS:
;
;   UNIT - a logical unit number (a scalar).  In the case of GET_LUN,
;          a file unit will be allocated and returned in UNIT.  In the
;          default case, or REOPEN, UNIT must be a valid file unit
;          upon input.  For REOPEN the corresponding file must be
;          seekable.
;
;   FILENAME - a scalar string specifying the filename path (ignored
;              for REOPEN).
;
;   OFFSET - upon return, the file offset of the next available SAVE
;            record.
;
;
; KEYWORDS:
;
;   ACCESS - a scalar string, case insensitive:
;               'R' - read-only access
;               'W' - write access (new file)
;               'RW' - read-write access (existing file)
;            Default: 'R' - read-only
;
;   GET_LUN - if set, the file unit is allocated using GET_LUN
;
;   FORCE - if set, then the file is opened despite a detected file
;           format inconsistency.
;
;   REOPEN - if set, then an already-opened file is manipulated.  The
;            valid file unit must be specified by UNIT, and FILENAME
;            is ignored.
;
;   COMPATIBILITY - a string, which describes the format to be used in
;          the output file.  Possible values are:
;
;                  'IDL4' - format of IDL version 4;
;                  'IDL5' - format of IDL versions 5.0-5.3;
;                  'IDL6' - not supported yet, for versions 5.4-above;
;                  'RIVAL1' - same as 'IDL5', plus a directory entry is
;                            written to the file.
;           Note that files written in IDL5 format may still be
;           readable by IDL v.4.
;           Default: 'IDL5'
;
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Change BLOCK to STREAM to support VMS properly, 14 Feb 2001, CM
;   Added notification about RSI License, 13 May 2002, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_open.pro,v 1.13 2009/11/22 22:50:49 craigm Exp $
;
;-
; Copyright (C) 2000-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSV_PTRSUM
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Construct an inventory of heap data accessible to a variable
;
; CALLING SEQUENCE:
;   CMSV_PTRSUM, VAR, LIST
;   
; DESCRIPTION: 
;
;   This procedure constructs an inventory of heap data that is
;   accessible to a single variable.  It searches all array elements,
;   recursively through structure tags, and by dereferencing pointers.
;   Users can use this procedure to determine all heap variables that
;   need to be saved to disk.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt. 
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; INPUTS:
;
;   VAR - the variable to be examined
;
;   LIST - upon output, an array of pointers, each of which points to
;          a heap variable accessible to VAR.  If there are no heap
;          data pointed to by VAR, then LIST returns a NULL value.
;
; KEYWORDS:
;
;   NULL - if set, return the null value in LIST instead of the
;          pointer list.  VAR is ignored.
;
;   HAS_OBJECTS - upon return, the value is 1 if VAR contains or
;                 points to an object reference, and 0 if not.
;
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Make version checks with correct precision, 19 Jul 2001, CM
;   Added notification about RSI License, 13 May 2002, CM
;
; $Id: cmsv_ptrsum.pro,v 1.7 2002/05/13 06:41:10 craigm Exp $
;
;-
; Copyright (C) 2000-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSV_RDATA
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Read SAVE-formatted data variable record from input block or file unit
;
; CALLING SEQUENCE:
;   CMSV_RDATA, BLOCK, POINTER, SIZE, DATA, UNIT=UNIT, $
;          TEMPLATE=TEMPLATE, /TEMPORARY, PTR_INDEX=PTR_INDEX, $
;          PTR_CALLBACK=PTR_CALLBACK, PTR_OFFSETS=PTR_OFFSETS, $
;          OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   CMSV_RDATA reads the data portion of an IDL SAVE variable record.
;   An IDL variable is stored in two components: the type descriptor
;   which describes the name, type, and dimensions of the variable;
;   and the data record, which contains the raw data of the variable.
;   This procedure reads the raw data and returns it to the user.  The
;   initial type portion of the record must have already been read
;   using the CMSV_RVTYPE procedure.
;
;   CMSV_RDATA supports the following variable types:
;
;     BYTE(1),INT(2),LONG(3) - integer types
;     UINT(12),ULONG(13),LONG64(14),ULONG64(15) - integer types (IDL >5.2 only)
;     FLOAT(4),DOUBLE(5),COMPLEX(6),DCOMPLEX(9) - float types
;     STRING(7) - string type
;     STRUCT(8) - structure type
;     POINTER(10) - pointer type - SEE BELOW
;     NOT SUPPORTED - OBJ(11) - object reference type - NOT SUPPORTED
;
;   Arrays and structures containing any of the supported types are
;   supported (including structures within structures).
;
;   For scalars and arrays of numeric or string types, the caller must
;   only supply the SIZE parameter, which specifies the type and
;   dimensions of the variable to be read.  This information can be
;   obtained from the CMSV_RVTYPE routine. The data is returned in the
;   output parameter DATA.
;
;   For structure data, in addition to specifying the SIZE array, the
;   user must also supply a "template" describing the structure into
;   which the data will be read.  This template is simply a "blank"
;   form of the data structure, and is returned by CMSV_RVTYPE.
;
;   Thus, a simple way to read structure, numeric or string data is
;   the following code (with error checking removed)
;
;     CMSV_RVTYPE, block, pointer, name, size, template=template, unit=unit
;     CMSV_RDATA, block, pointer, size, data, template=template, unit=unit
;
;   [ This code assumes the record header has been read with
;   CMSV_RREC. ]
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; POINTER DATA
;
;   Pointer data stored in IDL SAVE files are particularly difficult
;   to manage, because the actual heap variables are stored in
;   separate records which *precede* the record of interest.  Thus, if
;   your application requires the reading of pointer data, you must
;   perform special processing in your own code in order to support
;   it.  In essence, you must maintain an inventory of heap variables
;   as they are encountered in the file.
;
;   If these procedures are not followed then pointer data will not be
;   read, and a LONG integer value appears in the pointers' places.
;   Under IDL 4, pointer data can never be read.
;
;   This is accomplished by placing some additional logic in your file
;   processing loop.  There are four separate components to this: (1)
;   loop initialization; (2) reading a HEAP_INDEX record; (3) parsing
;   a HEAP_DATA record; and (4) passing extra arguments to CMSV_RDATA.
;   The additional state information is maintained in two variables
;   named PTR_INDEX, which keeps track of the heap variable numbers,
;   and PTR_OFFSETS, which stores the file location of each variable.
;
;   (1) Loop initialization: is quite simple, use the following code:
;       ptr_index   = [0L]
;       ptr_offsets = [0L]
;       ptr_data    = [ptr_new()]
;
;   (2) Reading HEAP_INDEX, which is an array of values indicating
;       the heap variable numbers of each heap variables.  These
;       values are stored in PTR_INDEX:
;
;          CMSV_RHEAP, block, pointer, index, unit=unit
;          ptr_index   = [ptr_index, index]
;          ptr_offsets = [ptr_offsets, lonarr(n_elements(index))]
;          ptr_data    = [ptr_data, ptrarr(n_elements(index))]
;
;   (3) Parse the HEAP_DATA record.  Here were are interested in the
;       heap variable number, and the file offset.
;       
;       opointer = pointer
;       CMSV_RVTYPE, block, pointer, vindex, /heap, unit=unit
;       
;       vindex = floor(vindex(0))
;       wh = where(ptr_index EQ vindex)
;       ptr_offsets(wh(0)) = offset + opointer
;
;       Keep in mind that the file offset is OFFSET+POINTER.
;
;   (4) Pass extra parameters to CMSV_RDATA.  The user simply passes
;       these extra variables to the CMSV_RDATA procedure, which
;       automatically recognizes heap data and reads it from the
;       appropriate location.
;
;       CMSV_RVTYPE, block, pointer, name, size, unit=unit, template=tp
;       CMSV_RDATA, block, pointer, size, data, template=tp, $
;         unit=unit, ptr_offsets=ptr_offsets, $
;         ptr_index=ptr_index, ptr_data=ptr_data
;
;   If this technique is used properly, only those heap variables
;   which are needed are read.  Thus, there are never any lost or
;   dangling pointers.  Since each bit of heap data is stored in a
;   variable returned to the user, it is not necessary to
;   PTR_FREE(ptr_data); in fact, doing so would corrupt the input
;   data.
;
; BLOCK, POINTER, OFFSET
;
;   This procedure can read data from a byte array, a file unit, or
;   both.  In fact, this procedure is designed to implement "lazy"
;   reading from a file, which is to say, it normally reads from a
;   byte array of data.  However, if the requested data goes beyond
;   the end of the byte array, more data is read from the file on
;   demand.  This way the user gets the benefit of fast memory access
;   for small reads, but guaranteed file access for large reads.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be read is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN.
;
;   POINTER - a long integer, a pointer to the next byte to be read
;             from BLOCK.  CMSVLIB routines will automatically
;             advance the pointer.
;
;   SIZE - an array of integers describing the type and dimensions of
;          the variable to be read, in the format returned by the
;          SIZE() routine.  This parameter is required.
;
;   DATA - upon output, the data variable.  If any heap data is read,
;          the user is ultimately responsible for freeing it.
;
;
; KEYWORDS:
;
;   UNIT - a file unit.  If a library routine reads to the end of
;          BLOCK, or if BLOCK is undefined, then this file UNIT will
;          be accessed for more data.  If undefined, then BLOCK must
;          contain the entire file in memory.
;
;   TEMPLATE - for structure data (data type 8), a "blank" structure
;              containing the fields and data values to be read in.
;              This structure is returned by CMSV_RVTYPE.
;              This keyword is mandatory for structure data.
;
;   TEMPORARY - if set, BLOCK becomes undefined upon return.
;
;   PTR_OFFSETS - array of file offsets, as described above.  Default:
;                 pointer data is converted to an integer.
;
;   PTR_INDEX - array of heap variable indices, as described above.
;               Default:  pointer data is converted to an integer.
;
;   PTR_DATA - array of pointers, as described above.  
;               Default:  pointer data is converted to an integer.
;
;   OFFSET - the file offset of byte zero of BLOCK.  Default: 0
;            (OFFSET is used by this routine)
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added UNDEFINED data type for IDL >5.3, CM, 21 Apr 2001
;   Fixed bug for pointers within structures, CM, 21 Apr 2001
;   Add support for IDL 4 byte-compiled strings, CM, 22 Apr 2001
;   Make version checks with correct precision, 19 Jul 2001, CM
;   Added notification about RSI License, 13 May 2002, CM
;   Clarify and speed some of the code, 22 Nov 2009, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_rdata.pro,v 1.11 2009/11/22 23:04:43 craigm Exp $
;
;-
; Copyright (C) 2000-2001, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; ---------------- Convert from network to host order ------------------
pro cmsv_rconv, data

  ;; Inspired by IDL Astronomy Library routine IEEE_TO_HOST
  common cmsv_conv_common, lendian
  if n_elements(lendian) EQ 0 then begin
      ;; Little-endian?
      lendian = (long(['01'xb,'02'xb,'03'xb,'04'xb],0,1))(0) NE '01020304'xl
  endif

  sz = size(data)
  case sz(sz(0)+1) of 
      1:  return                    ;; Byte
      2:  byteorder, data, /NTOHS   ;; Integer
      3:  byteorder, data, /NTOHL   ;; Long
      4:  byteorder, data, /XDRTOF  ;; Float
      5:  byteorder, data, /XDRTOD  ;; Double
      6:  byteorder, data, /XDRTOF  ;; Complex
      9:  byteorder, data, /XDRTOD  ;; DComplex
      12: byteorder, data, /NTOHS   ;; UInt
      13: byteorder, data, /NTOHL   ;; ULong
      14: if lendian EQ 1 then byteorder, data, /L64SWAP ;; LONG64
      15: if lendian EQ 1 then byteorder, data, /L64SWAP ;; ULONG64
      ELSE: 
  endcase

end

; ---------------- Read heap data variable ---------------------------
pro cmsv_rhdata, block, pointer, data, index, offsets, pdata, unit=unit0, $
                 offset=offset0, status=status, errmsg=errmsg

  status = 0
  errmsg = ''
  if n_elements(offset0) EQ 0 then offset = 0L $
  else                             offset = floor(offset0(0))

  if n_elements(offsets) EQ 0 OR n_elements(index) EQ 0 then begin
      errmsg = 'ERROR: CMSV_RDATA: must specify INDEX and OFFSETS data'
      return
  endif

  if n_elements(offsets) NE n_elements(index) then begin
      errmsg = 'ERROR: CMSV_RDATA: dimensions of OFFSETS and '+ $
        'INDEX do not match'
      return
  endif
  
  if n_elements(unit0) EQ 0 then begin
      errmsg = 'ERROR: CMSV_RDATA: Must specify UNIT when reading heap data'
      return
  endif
  unit = floor(unit0(0))

  sz = size(data)
  odata = temporary(data)

  ;; Create the properly sized array.  Don't worry about getting the
  ;; dimensions right since it will be reformed.
  if sz(0) GT 0 then begin
      data = ptrarr(sz(sz(0)+2))
  endif else begin
      data = ptr_new()
  endelse

  blimits = offset + [0,n_elements(block)-1]

  point_lun, -unit, opos
  null = ptr_new()
  
  for i = 0, n_elements(odata)-1 do begin
      if odata(i) EQ 0 then goto, NEXT_HEAP

      wh = (where(odata(i) EQ index, ct))(0)
      if ct EQ 0 then goto, NEXT_HEAP

      if n_elements(pdata) GT wh then begin
          if pdata(wh) NE null then begin
              data(i) = pdata(wh)
              goto, NEXT_HEAP
          endif
      endif

      point_lun, unit, offsets(wh)

      block1 = 0 & dummy = temporary(block1)
      p1 = 0L
      cmsv_rvtype, block1, p1, varname, sz1, status=status, template=tp1, $
        unit=unit, errmsg=errmsg, structure_name=stname, /heap
      if status EQ 0 then return

      if floor(varname) NE odata(i) then begin
          errmsg = 'ERROR: CMSV_RDATA: heap index mismatch'
          status = 0
          return
      endif

      val = 0 & dummy = temporary(val)
      cmsv_rdata, block1, p1, sz1, val, template=tp1, status=st1, $
        ptr_offsets=offsets, ptr_index=index, ptr_data=pdata, $
        ptr_callback='DEFAULT', unit=unit, errmsg=errmsg
      if status EQ 0 then return

      ;; Deal with case of undefined heap var
      if n_elements(val) GT 0 then data(i) = ptr_new(temporary(val)) $
      else                         data(i) = ptr_new(/allocate_heap)
      if n_elements(pdata) GT wh then pdata(wh) = data(i)
      NEXT_HEAP:
  endfor

  point_lun, unit, opos
  status = 1
  return
end

; --------------------------- Main procedure ------------------------------
pro cmsv_rdata, block, pointer, sz, data, offset=offset, unit=unit, $
                template=template1, status=status, errmsg=errmsg, $
                start=start, temporary=temp, $
                bytelong=bytelong, bcstring40=bcstring, $
                ptr_offsets=pprivate, ptr_callback=callback0, $
                ptr_index=pindex, ptr_data=pdata

  ;; VAR_DATA
  ;;   LONG - START_DATA TOKEN - value 7
  ;;   for bytes - consecutive bytes
  ;;   for (u)ints - upcast to type long 
  ;;   for (u)longs - consecutive longs
  ;;   for pointers - consecutive longs, indices into saved heap data
  ;;   for strings - consecutive STRING's
  ;;   for structs - compacted versions of above
  forward_function fix, uint, complex, dcomplex, make_array

  data = 0 & dummy = temporary(data)
  if n_elements(start) EQ 0 then start = 1
  if n_elements(pointer) EQ 0 then pointer = 0L

  tp0 = sz(sz(0)+1)
  tp = tp0

  ;; =====================================
  if tp EQ 0 then begin     ;; UNDEFINED type
      data = 0
      dummy = temporary(data)
      return
  endif
  ;; =====================================
  if (tp EQ 11) then begin  ;; OBJECT type
      status = 0
      errmsg = 'ERROR: CMSV_RDATA: cannot read object data'
      return
  endif

  if keyword_set(start) then begin
      start_token = cmsv_rraw(/long, block, pointer, status=status, $
                               unit=unit, errmsg=errmsg)
      if start_token NE 7 then begin
          errmsg = 'ERROR: CMSV_RDATA: invalid or corrupted data'
          status = 0
      endif
      if status EQ 0 then return
  endif

  nelt = sz(sz(0)+2)
  ;; =====================================
  if (tp EQ 10) then tp = 3 ;; Pointer type -> LONG

  ;; =====================================
  if (tp EQ 8) then begin   ;; Structure type
      if n_elements(template1) EQ 0 then begin
          errmsg = 'ERROR: CMSV_RDATA: TEMPLATE must be passed for structures'
          status = 0
          return
      endif
      data = reform(replicate(template1(0), nelt), sz(1:sz(0)), /overwrite)
      tp1 = data(0)
      tn = tag_names(data(0)) & nt = n_elements(tn)
      ssz = lonarr(12, nt)
      for j = 0L, nt-1 do begin
          ssz(0, j) = size(data(0).(j))
      endfor
      for i = 0L, nelt-1 do begin
          for j = 0L, nt-1 do begin
              cmsv_rdata, block, pointer, ssz(*,j), dataij, start=0, $
                template=(tp1.(j))(0), $
                ptr_offsets=pprivate, ptr_index=pindex, ptr_data=pdata, $
                ptr_callback=callback0, $
                unit=unit, status=status, errmsg=errmsg
              data(i).(j) = dataij
              
              if status EQ 0 then return
          endfor
      endfor
      return
  endif

  ;; =====================================
  if tp EQ 7 then begin     ;; String type
      if sz(0) EQ 0 then data = '' $
      else data = reform(strarr(sz(sz(0)+2)), sz(1:sz(0)), /overwrite)
      for i = 0L, nelt-1 do begin
          len = cmsv_rraw(/long, block, pointer, status=status, $
                             unit=unit, errmsg=errmsg)
          if status EQ 0 then return
          if len GT 0 OR keyword_set(bcstring) then $
            data(i) = cmsv_rraw(/string, block, pointer, unit=unit, $
                                status=status, errmsg=errmsg)
          if status EQ 0 then return
      endfor
      if sz(0) EQ 0 then data = data(0)
      return
  endif
  
  ;; Sometimes the input data is stored as a different type
  common cmsv_datatypes, stype, sbyte, nbyte, selts
  if n_elements(stype) EQ 0 then begin
      ;;      0      1       2       3        4        5         6    7   8
      ;;          byte     int    long    float    double   complex str struct
      stype =['','BYTE', 'LONG', 'LONG', 'FLOAT', 'DOUBLE', 'FLOAT', '', '' ]
      sbyte =[0,     1,      4,      4,       4,        8,       4,   0,  0 ]
      selts =[0,     1,      1,      1,       1,        1,       2,   0,  0 ]

      ;;                  9     10   11     12       13        14
      ;;            dcomplex   ptr   obj   uint     ulong    long64   ulong64
      stype =[stype,'DOUBLE', 'LONG', '', 'ULONG', 'ULONG', 'LONG64','ULONG64']
      sbyte =[sbyte,      8,     4,   0,     4,       4,        8,        8, 0]
      selts =[selts,      2,     1,   0,     1,       1,        1,        1, 0]
  endif

  status = 0
  nb = sbyte(tp<16)
  if nb EQ 0 then begin
      errmsg = ('ERROR: CMSV_RDATA: cannot read specified type ('+ $
                strtrim(tp,2)+')')
      return
  endif
  nelt1 = nelt*selts(tp<16)     ;; Account for complex type
  nb  = nb*nelt1                ;; Number of total bytes
  nb1 = long(floor((nb+3)/4)*4) ;; Number of bytes, rounded to next long
  rt  = stype(tp<16)            ;; Read type, as opposed to output type

  ;; Error handler returns zero and error condition
  on_ioerror, READ_ERROR
  if 0 then begin
      READ_ERROR: CMSV_RDATA:
      errmsg = 'ERROR: CMSV_RDATA: a read error occurred'
      return
  end

  ;; =====================================
  ;; Byte values handled specially....    argghhh!
  if tp EQ 1 then begin
     if NOT keyword_set(bytelong) then begin
        ;; BYTELONG is NOT set
        nb1 = cmsv_rraw(/long, block, pointer, unit=unit, $
                        errmsg=errmsg, status=status)
        if status EQ 0 then return
        if nb1 NE nb then begin
           errmsg = 'ERROR: CMSV_RDATA: byte count and array size do not agree'
           status = 0
           return
        endif
        ;; Round up to the nearest 4-byte boundary
        nb1 = long(floor((nb+3)/4)*4)
     endif else begin
        ;; BYTELONG is set
        
        ;; Input data will be read as long... required when decoding
        ;; values in code blocks
        nb    = sbyte(3)
        nelt1 = nelt*selts(3)
        nb    = nb*nelt1
        nb1   = nb
        rt    = stype(3)
     endelse
  endif

  ;; =====================================
  ;; Perform default type conversions on the data
  pp = pointer
  if n_elements(block) GT 0 then begin
      if pointer+nb GT n_elements(block) then begin
          dummy = cmsv_rraw(block, pointer, nb, /byte, /buffer, unit=unit, $
                            status=status, errmsg=errmsg)
          if status EQ 0 then return
      endif

      if keyword_set(temp) then $
        data = call_function(rt, (temporary(block))(pp:pp+nb-1), 0, nelt1) $
      else $
        data = call_function(rt, block(pp:pp+nb-1), 0, nelt1)
  endif else begin
      sz1 = size(call_function(rt,0))
      data = make_array(type=sz1(sz1(0)+1), nelt1, /nozero)
      readu, unit(0), data
  endelse
  pointer = pointer + nb1
  cmsv_rconv, data

  ;; =====================================
  ;; Special conversions on certain data types
  case tp of
     2:  data = fix(temporary(data))              ;; 2 - int
     12: data = uint(temporary(data))             ;; 12 - uint
     6:  data = complex(temporary(data), 0, nelt) ;; 6 - complex (float)
     9:  data = dcomplex(temporary(data), 0, nelt);; 9 - dcomplex (double)
     else:
  endcase

  ;; Reset error handler
  on_ioerror, NULL

  ;; =====================================
  ;; Convert to pointer type
  if tp0 EQ 10 then if double(!version.release) GE 5D $
    AND n_elements(pprivate) GT 0 AND n_elements(pindex) GT 0 then begin

      ;; The data we have read is actually just an index number into
      ;; the heap.  We must read each heap variable separately.
      if n_elements(callback0) GT 0 then callback = strtrim(callback0(0),2) $
      else                               callback = 'DEFAULT'
      if callback EQ 'DEFAULT' then      callback = 'CMSV_RHDATA'

      if callback NE '' then begin
          call_procedure, callback, block, pointer, data, $
            pindex, pprivate, pdata,$
            unit=unit, offset=offset, status=status, errmsg=errmsg
          if status EQ 0 then return
      endif
  endif
      
  ;; =====================================
  ;; Make sure that the output array has the right dimensions
  if sz(0) GT 0 then data = reform(data, sz(1:sz(0)), /overwrite) $
  else data = data(0)

  status = 1
  return
end
;+
; NAME:
;   CMSV_RRAW
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Read raw SAVE data from input block or file unit
;
; CALLING SEQUENCE:
;   DATA = CMSV_RRAW( BLOCK, POINTER, NELT, UNIT=UNIT, $
;                     STRING=STRING, LONG=LONG, BYTE=BYTE, TYPE=TYPE, $
;                     OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG )
;   
; DESCRIPTION: 
;
;   This function reads raw integer or string data from an IDL SAVE
;   file.  This is the lowest level reading function in the library,
;   intended for developers who are investigating new and existing
;   SAVE file formats.
;
;   The primary use of this function will be to read raw integer and
;   string data from the input.  By default, a single value is read as
;   a scalar; however a vector of values can be read using the NELT
;   parameter.  Special keywords are provided for the common data
;   types STRING, LONG and BYTE.  Other integer types can be read
;   using the TYPE keyword.  Users who want to read the data from an
;   IDL variable should use CMSV_RDATA, which can handle
;   multidimensional data, as well as floating point and structure
;   data.
;
;   A secondary use of this function is to buffer the data in BLOCK.
;   This will ensure that BLOCK contains enough data to convert NELT
;   integers without reading from disk.  CMSV_RRAW itself does not
;   convert any values so the return value should be ignored.
;
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; BLOCK, POINTER, OFFSET
;
;   This procedure can read data from a byte array, a file unit, or
;   both.  In fact, this procedure is designed to implement "lazy"
;   reading from a file, which is to say, it normally reads from a
;   byte array of data.  However, if the requested data goes beyond
;   the end of the byte array, more data is read from the file on
;   demand.  This way the user gets the benefit of fast memory access
;   for small reads, but guaranteed file access for large reads.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be read is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN.
;
;   POINTER - a long integer, a pointer to the next byte to be read
;             from BLOCK.  CMSVLIB routines will automatically
;             advance the pointer.
;
;   NELT - optional parameter specifying the number of values to read.
;          If unspecified, then a scalar value is read and returned.
;          If specified, then a vector of NELT values is read and
;          returned.
;
;
; KEYWORDS:
;
;   BUFFER - if set, CMSV_RRAW will ensure that BLOCK contains at
;            least NELT values without converting them.  The return
;            value should be ignored.  This keyword is ignored for
;            strings.
;
;   LONG - if set, the values are converted as LONG integers.
;
;   BYTE - if set, the values are converted as BYTEs.
;
;   STRING - if set, the values are converted as STRINGs.  Each string
;            may be of variable length.
;
;   TYPE - if none of the above keywords is set, then values of type
;          TYPE are read.  TYPE should be a string, one of 'BYTE',
;          'FIX', 'LONG', 'ULONG', 'LONG64', or 'ULONG64'.
;          If no type is specified then BYTEs are read.
;
;   UNIT - a file unit.  If a library routine reads to the end of
;          BLOCK, or if BLOCK is undefined, then this file UNIT will
;          be accessed for more data.  If undefined, then BLOCK must
;          contain the entire file in memory.
;
;   OFFSET - the file offset of byte zero of BLOCK.  Default: 0
;            (OFFSET is used by this routine)
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added notification about RSI License, 13 May 2002, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_rraw.pro,v 1.7 2009/11/22 22:50:49 craigm Exp $
;
;-
; Copyright (C) 2000-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSV_RREC
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Read SAVE-formatted record header from input block or file unit
;
; CALLING SEQUENCE:
;   CMSV_RREC, BLOCK, POINTER, DATA, UNIT=UNIT, $
;        BLOCK_TYPE=BLOCK_TYPE, BLOCK_NAME=BLOCK_NAME, NEXT_BLOCK=NEXT_BLOCK, $
;        INITIALIZE=INITIALIZE, FULL=FULL, PROMOTE64=PROMOTE64, $
;        OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   This procedure reads the header of an IDL SAVE record.  The header
;   consists of four bytes at the beginning of each record which
;   indentifies the type and size of the record.  This procedure also
;   additionally reads many full records as noted below.
;
;   Users can determine the block type by examining the values
;   returned in the BLOCK_TYPE and BLOCK_NAME keywords.  The following
;   values are supported.  Some record types contain additional data.
;   CMSV_RREC reads some of these record types automatically (those
;   entries below marked with [this procedure]).  Other records do not
;   contain any additional data at all (those entries marked with an
;   [empty]), and thus require no further processing.
;
;    BLOCK_TYPE      BLOCK_TYPE         READ RECORD DATA WITH...
;
;       0         = 'START_MARKER'      [empty]
;       1         = 'COMMON_BLOCK'      [this procedure]
;       2         = 'VARIABLE'          CMSV_RVTYPE / CMSV_RDATA
;       3         = 'SYSTEM_VARIABLE'   CMSV_RVTYPE / CMSV_RDATA
;       6         = 'END_MARKER'        [empty]
;       10        = 'TIMESTAMP'         [this procedure]
;       12        = 'COMPILED'          no published procedure
;       13        = 'IDENTIFICATION'    [this procedure]
;       14        = 'VERSION'           [this procedure]
;       15        = 'HEAP_INDEX'        [this procedure]
;       16        = 'HEAP_DATA'         CMSV_RVTYPE
;       17        = 'PROMOTE64'         [empty]
;       19        = 'NOTICE'            [this procedure]
;
;   For records that contain variable data, the external procedures
;   CMSV_RVTYPE and CMSV_RDATA must be used, as noted above.
;   Otherwise CMSV_RREC will read and convert the appropriate data
;   automatically and return it in the DATA positional parameter.
;
;   The offset of the next record is returned in the NEXT_BLOCK
;   keyword.  For file input, the command, "POINT_LUN, UNIT,
;   NEXT_BLOCK" will position the file pointer to the next block.
;
;   Users should be aware that the SAVE files produced by IDL version
;   5.4 appear to have a different header format.  The new header size
;   is five bytes, and is incompatible with the older format.  In
;   order to activate the longer header size, the PROMOTE64 keyword
;   must be set.
;
;   By default the entire record is not read from the file at once.
;   Users that wish to operate on the entire record immediately should
;   set the FULL keyword.
;
;   After issuing a POINT_LUN the block cache in BLOCK must be reset
;   using the /INITIALIZE keyword.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; SPECIFIC RECORD TYPES
;
;   CMSV_RREC reads certain specific record types automatically and
;   returns the data in the positional parameter data.  Users should
;   pass a named variable in this parameter to retrieve the return
;   value.
;
;   When a record of type 'VERSION' (14) is encountered, it is read,
;   and returned as a structure. The returned data are of the form:
;
;         { FORMAT_VERSION: 0L, $   ; Format version number of file
;           ARCH: '', $             ; !VERSION.ARCH of creating host
;           OS: '', $               ; !VERSION.OS of creating host
;           RELEASE: '' }           ; !VERSION.RELEASE of creating host
;
;   When a record of type 'TIMESTAMP' (10) is encountered, it is read,
;   and returned as a structure. The returned data are of the form:
;
;          { SAVE_DATE: '', $  ; Date the save file was created
;            SAVE_USER: '', $  ; User name who  created file
;            SAVE_HOST: '' }   ; Host name that created file
;
;   Save files created by IDL version 4 do not contain a timestamp
;   record.
;
;   When a record of type 'IDENTIFICATION' (13) is encountered, it is
;   read, and returned as a structure.  The returned data are of the
;   form:
;
;          { AUTHOR: '', $  ; Author of SAVE file
;            TITLE:  '', $  ; Title of SAVE file
;            IDCODE: '' }   ; Identifying code for SAVE file
;
;   It appears that this record is not used in IDL version 5 or later.
;
;   When a record of type 'COMMON_BLOCK' (1) is encountered, it is
;   read and returned.  A common block descriptor consists of an array
;   of strings whose first element is the common block name, and whose
;   remaining elements are the common block variable names.  No
;   variable data are stored with the common block definition.
;
;   When a record of type 'HEAP_INDEX' (15) is encountered, it is read
;   and returned in DATA.  The heap index specifies a list of which
;   heap variables are stored in the current save file.  These indices
;   are simply numbers which identify each heap variable (i.e.,
;   "<PtrHeapVar2>" would have an index of 2).  Users should note that
;   the heap index will not necessarily be sequentially increasing,
;   and may have gaps.
;
;   When a record of type 'NOTICE' (19) is encountered, it is read and
;   returned in DATA.  It is a structure with one field: {TEXT: ''},
;   where TEXT is the text content of the notice.
;
;   Users should consult CMSV_RDATA for instructions on how to read
;   heap data.
;   
;
; BLOCK, POINTER, OFFSET
;
;   This procedure can read data from a byte array, a file unit, or
;   both.  In fact, this procedure is designed to implement "lazy"
;   reading from a file, which is to say, it normally reads from a
;   byte array of data.  However, if the requested data goes beyond
;   the end of the byte array, more data is read from the file on
;   demand.  This way the user gets the benefit of fast memory access
;   for small reads, but guaranteed file access for large reads.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be read is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.  
;
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN.
;
;   POINTER - a long integer, a pointer to the next byte to be read
;             from BLOCK.  CMSVLIB routines will automatically
;             advance the pointer.
;
;
; KEYWORDS:
;
;   UNIT - a file unit.  If a library routine reads to the end of
;          BLOCK, or if BLOCK is undefined, then this file UNIT will
;          be accessed for more data.  If undefined, then BLOCK must
;          contain the entire file in memory.
;
;   OFFSET - the file offset of byte zero of BLOCK.  Default: 0
;            (OFFSET is used by this routine)
;
;   BLOCK_TYPE - upon return, the numeric record type, as described
;                above.
;
;   BLOCK_NAME - upon return, a scalar string specifying the record
;                type, as specified above.
;
;   NEXT_BLOCK - upon return, file offset of the next record in the
;                file.
;
;   INITIALIZE - if set, then BLOCK and POINTER are initialized to a
;                pristine state.  All data in these two variables is
;                lost before reading the next record.
;
;   FULL - if set, then the entire record will be read into BLOCK.
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Fix typo for RHEAP call, CM, 21 Apr 2001
;   Added notification about RSI License, 13 May 2002, CM
;   Added NOTICE record type, 09 Jun 2003, CM
;   Read record header as ULONG, 26 Sep 2009, CM
;   Bug fix to previous change, 22 Nov 2009, CM
;   Support for newer IDL 64-bit files which use a 
;    "standard" record header size and a previously unused
;    field, 11 Jan 2010, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_rrec.pro,v 1.15 2010/01/11 08:58:13 craigm Exp $
;
;-
; Copyright (C) 2000-2001, 2003, 2009, 2010, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; ----------------- Read common block descriptor ----------------------

pro cmsv_rcomm, block, pointer, names, unit=unit, offset=offset, $
                status=status, errmsg=errmsg

  status = 0
  if n_elements(pointer) EQ 0 then pointer = 0L
  names = 0 & dummy = temporary(names)
  
  ncommon = cmsv_rraw(/long, block, pointer, unit=unit, $
                      status=status, errmsg=errmsg)
  if status EQ 0 then return
  if ncommon LE 0 then begin
      status = 0
      errmsg = 'ERROR: CMSV_RREC: invalid common record block'
      return
  endif

  names = cmsv_rraw(/string, block, pointer, ncommon+1, unit=unit, $
                    status=status, errmsg=errmsg)
  return
end


; ----------------- Read heap index ---------------------------------

pro cmsv_rheap, block, pointer, index, unit=unit, offset=offset, $
                status=status, errmsg=errmsg

  ;; HEAP_INDEX
  ;;   LONG - N_HEAP - number of heap values
  ;;   LONGxN_HEAP - heap indices

  if n_elements(pointer) EQ 0 then pointer = 0L
  index = 0 & dummy = temporary(index)

  n_heap = cmsv_rraw(/long, block, pointer, unit=unit, $
                     status=status, errmsg=errmsg)
  if status then $
    index = cmsv_rraw(/long, block, pointer, n_heap, unit=unit, $
                      status=status, errmsg=errmsg)

  return
end

; ------------------------ Read time stamp record -----------------------

pro cmsv_rstamp, block, pointer, tstamp, unit=unit, offset=offset, $
                 status=status, errmsg=errmsg

  ;; TIMESTAMP
  ;;   BYTEx400 - empty (?) legacy area
  ;;   STRING - save date (as a string)
  ;;   STRING - user name
  ;;   STRING - hostname
  status = 0
  if n_elements(pointer) EQ 0 then pointer = 0L
  pointer = pointer + '400'xl
  tstamp = 0 & dummy = temporary(tstamp)

  strings = cmsv_rraw(/string, block, pointer, 3, unit=unit, $
                      status=status, errmsg=errmsg)
  if status EQ 0 then return

  tstamp = {save_date: strings(0), save_user: strings(1), save_host:strings(2)}
  return
end


; ---------------------- Read Version Info ---------------------------

pro cmsv_rversion, block, pointer, vers, unit=unit, offset=offset, $
                   status=status, errmsg=errmsg
  ;; VERSION_STAMP
  ;;   LONG - Major version number
  ;;   STRING_DATA - Host architecture ( = !version.arch )
  ;;   STRING_DATA - Host OS ( = !version.os )
  ;;   STRING_DATA - IDL release ( = !version.release )

  if n_elements(pointer) EQ 0 then pointer = 0L
  major_release = 5
  vers = 0 & dummy = temporary(vers)

  arch = '' & os = '' & release = ''
  major_release = cmsv_rraw(/long, block, pointer, unit=unit, $
                            status=status, errmsg=errmsg)
  if status EQ 0 then return

  strings = cmsv_rraw(/string, block, pointer, 3L, status=status, $
                      unit=unit, errmsg=errmsg)
  if status EQ 0 then return
  status = 1
  
  vers = {format_version: major_release, arch: strings(0), $
          os: strings(1), release: strings(2)}
  return
end

; --------------------------- Read Identification --------------------

pro cmsv_rident, block, pointer, ident, unit=unit, offset=offset, $
                 status=status, errmsg=errmsg

  ;; IDENT
  ;;   STRING - author
  ;;   STRING - title
  ;;   STRING - idcode

  strings = cmsv_rraw(/string, block, pointer, 3, unit=unit, $
                      status=status, errmsg=errmsg)
  if status EQ 0 then return

  ident = {author: strings(0), title: strings(1), idcode:strings(2)}
  return
end

; --------------------------- Read Notice --------------------

pro cmsv_rnotice, block, pointer, notice, unit=unit, offset=offset, $
                  status=status, errmsg=errmsg

  ;; NOTICE
  ;;   STRING - notice text

  string = cmsv_rraw(/string, block, pointer, 1, unit=unit, $
                      status=status, errmsg=errmsg)
  if status EQ 0 then return

  notice = {text: string}
  return
end


; ---------------------------- Main Read Routine ---------------------

pro cmsv_rrec, block, pointer, data, unit=unit, offset=offset, $
               status=status, errmsg=errmsg, compressed=compressed, $
               block_type=blocktype, block_name=blockname, next_block=np, $
               initialize=init, full=full, promote64=prom, $
               qblocknames=qblock

  common cmsave_block_names, block_ntypenames, block_typenames
  if n_elements(block_ntypenames) EQ 0 then begin
      block_ntypenames    = 20
      block_typenames     = strarr(block_ntypenames+1)+'UNKNOWN'
      block_typenames(0)  = 'START_MARKER'
      block_typenames(1)  = 'COMMON_BLOCK'
      block_typenames(2)  = 'VARIABLE'
      block_typenames(3)  = 'SYSTEM_VARIABLE'
      block_typenames(6)  = 'END_MARKER'
      block_typenames(10) = 'TIMESTAMP'
      block_typenames(12) = 'COMPILED'
      block_typenames(13) = 'IDENTIFICATION'
      block_typenames(14) = 'VERSION'
      block_typenames(15) = 'HEAP_INDEX'
      block_typenames(16) = 'HEAP_DATA'
      block_typenames(17) = 'PROMOTE64'
      block_typenames(19) = 'NOTICE'
  endif

  if keyword_set(qblock) then begin
      data = block_typenames
      return
  end

  status = 0
  errmsg = ''

  if n_elements(pointer) EQ 0 then pointer = 0L
  pointer = floor(pointer(0))
  if keyword_set(init) then begin
      block = 0 & dummy = temporary(block)
      pointer = 0L
  endif

  pointer0 = pointer
  op = pointer0  ;; "OP" = old pointer - points to curr record
  if n_elements(offset) GT 0 then op = op + offset(0)

  nlongs = 4L
  if keyword_set(prom) then nlongs = 5 ;; Special case of PROMOTE64
  rechead = cmsv_rraw(block, pointer, nlongs, unit=unit(0), $
                      status=status, errmsg=errmsg, type='ULONG')
  if status EQ 0 then return
  
  blocktype = rechead(0)
  blockname = block_typenames(blocktype < block_ntypenames)

  ;; "NP" = next pointer - points to next record
  np = rechead(1)

  ;; We assume this is a 64-bit pointer for two possibilities:
  ;;    1. the next pointer (32-bit) is less than "old pointer"
  ;;    2. PROMOTE64 has been set
  if (np LT op) OR keyword_set(prom) then begin
     ;; Compute new offset by combining two long values
     np = rechead(1) + rechead(2)*'100000000'XULL
     ;; Promote OFFSET
     if n_elements(offset) NE 0 then offset = ulong64(offset)

     ;; Sanity check on PROMOTE64-style headers
     if keyword_set(prom) then if rechead(4) NE 0 then begin
          errmsg = 'ERROR: CMSV_RREC: inconsistent 64-bit header'
          status = 0
          return
     endif
  endif


  if keyword_set(doprom) then begin
      ;; If file offset is to be promoted to 64-bit then we compute it
      ;; here.  The additional logic is to preserve 32-bit offsets in
      ;; most cases, and promote only if absolutely needed.  Signal an
      ;; error in earlier versions of IDL that don't support 64-bit
      ;; numbers.
      np = rechead(2) + rechead(1)
      if rechead(1) NE 0 AND rechead(2) NE 0 then begin
          if double(!version.release) LT 5.2D then begin
              errmsg = ('ERROR: CMSV_RREC: file contains a 64-bit file '+ $
                        'offset which is unstorable by this version of IDL')
              status = 0
              return
          endif
          np = cmsv_rraw(/long, block, pointer-3L*4L, type='ULONG64', $
                         status=status, errmsg=errmsg)
          if status EQ 0 then return
      endif

      ;; A 64-bit header has an extra long in it.  Read that now.
      ;; It should be zero.
      val0 = cmsv_rraw(/long, block, pointer, status=status, errmsg=errmsg)
      if status EQ 0 then return
      if val0 NE 0 then begin
          errmsg = 'ERROR: CMSV_RREC: inconsistent 64-bit header'
          status = 0
          return
      endif

  endif

  ;; Activate 64-bit promotion.  Blocks after this current one will
  ;; have 64-bit file offsets rather than 32-bit ones.
  if blocktype EQ 17 then prom = 1

  if keyword_set(full) then begin
      if n_elements(offset) EQ 0 then offset = 0L
      nbytes = np - (pointer0 + floor(offset(0)))
      if nbytes GT 0 then begin
          dummy = cmsv_rraw(block, 0L, nbytes, /byte, /buffer, unit=unit, $
                            status=status, errmsg=errmsg)
          if status EQ 0 then return
          block = block(0:nbytes-1)
      endif
  endif

  ;; Can't read compressed data for the moment
  if keyword_set(compressed) then begin
      status = 1
      return
  endif

  case blockname of 
      'COMMON_BLOCK': cmsv_rcomm, block, pointer, data, unit=unit, $
        status=status, errmsg=errmsg
      'HEAP_INDEX': cmsv_rheap, block, pointer, data, unit=unit, $
        status=status, errmsg=errmsg
      'VERSION': cmsv_rversion, block, pointer, data, unit=unit, $
        status=status, errmsg=errmsg
      'TIMESTAMP': cmsv_rstamp, block, pointer, data, unit=unit, $
        status=status, errmsg=errmsg
      'IDENTIFICATION': cmsv_rident, block, pointer, data, unit=unit, $
        status=status, errmsg=errmsg
      'NOTICE': cmsv_rnotice, block, pointer, data, unit=unit, $
        status=status, errmsg=errmsg
      ELSE: status = 1
  end

  return
end
;+
; NAME:
;   CMSV_RVTYPE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Read variable type information from input block or file unit
;
; CALLING SEQUENCE:
;   CMSV_RVTYPE, BLOCK, POINTER, NAME, SIZE, UNIT=UNIT, $
;          TEMPLATE=TEMPLATE, SUFFIX=SUFFIX, $
;          /NO_CREATE, /NO_TYPE, /HEAP, /SYSTEM, $
;          STRUCTURE_NAME=STNAME, $
;          NAMED_STRUCTS=STRUCTS, NAMED_CLASSES=CLASSES, $
;          OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   CMSV_RVTYPE reads the type portion of an IDL SAVE variable record.
;   An IDL variable is stored in two components: the type descriptor
;   which describes the name, type, and dimensions of the variable;
;   and the data record, which contains the raw data of the variable.
;   This procedure reads the type descriptor returns it to the user.
;   This procedure can also determine the name of a variable; the heap
;   index number of a heap variable; and other important information.
;   Once the type of the data has been determined, the data portion
;   can be read using the CMSV_RDATA procedure.
;
;   CMSV_RVTYPE should recognize and correctly return type descriptor
;   information about all known IDL data types, as of this writing.
;   It should be noted that CMSV_RDATA will not necessarily be capable
;   of reading all of these data types, but the description of the
;   data should still be readable.  Users can then use this
;   information to print a summary of the file contents for example.
;
;   The type information are normally returned in the SIZE parameter,
;   which gives the IDL variable type, and the dimensions of the
;   variable just as the IDL built-in function SIZE() would do.
;   However, in the case of structures, there is much more information
;   to convey.  To assist the user a blank template structure is
;   returned in the keyword parameter TEMPLATE, which they can then
;   pass on to CMSV_RDATA.
;
;   Users should be aware of structure and class name clashes.  The
;   problem arises because CMSV_RVTYPE must actually instantiate any
;   named structures or classes in the file.  If these named
;   structures clash with the definitions of the structures on the
;   user's local computer, then an error will result.  To prevent
;   this, the user can use the SUFFIX keyword.  If the SUFFIX keyword
;   contains a string, then this string is appended to any structure
;   names discovered in the save file, before instantiation.  Thus, as
;   long as the suffix is a unique string, there will be no clashes
;   with local structure definitions.  Users are advised to pick a
;   different suffix for *each* save file that they open.
;
;   CMSV_RVTYPE also provides some diagnostic information about the
;   variable.  Users can pass the NAMED_STRUCTS and NAMED_CLASSES
;   keywords in order to discover what named structures, classes and
;   superclasses are stored in the save file (this is especially
;   useful with the NO_TYPE keyword).  Since the contents of
;   NAMED_STRUCTS and NAMED_CLASSES are not destroyed, but appended to
;   instead, users are advised to clear these variables when opening
;   each new file.
;   
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; BLOCK, POINTER, OFFSET
;
;   This procedure can read data from a byte array, a file unit, or
;   both.  In fact, this procedure is designed to implement "lazy"
;   reading from a file, which is to say, it normally reads from a
;   byte array of data.  However, if the requested data goes beyond
;   the end of the byte array, more data is read from the file on
;   demand.  This way the user gets the benefit of fast memory access
;   for small reads, but guaranteed file access for large reads.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be read is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.  
;
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN.
;
;   POINTER - a long integer, a pointer to the next byte to be read
;             from BLOCK.  CMSVLIB routines will automatically
;             advance the pointer.
;
;   NAME - upon return, the identifier of the variable.  For named
;          variables, NAME is a string.  For heap variables, NAME is
;          an integer heap index.
;
;   SIZE - upon return, an integers array describing the variable type
;          and size, in the same format as returned by the built-in
;          function SIZE.
;
; KEYWORDS:
;
;   TEMPLATE - upon return, if the variable is a structure, TEMPLATE
;              will contain a single blank template structure, which
;              can be used in calls to CMSV_RDATA.
;
;   NO_CREATE - if set, then do not create any template structures
;               (saves execution time and structure name clashes).
;
;   NO_TYPE - if set, do not read type information.  CMSV_RVTYPE
;             returns only the variable NAME or heap index.
;
;   HEAP - if set, then read the variable type assuming it is a heap
;          variable (a HEAP_DATA record).
;
;   SYSTEM - if set, then read the variable type assuming it is a
;            system variable (a SYSTEM_VARIABLE record).
;
;   SUFFIX - a scalar string, the suffix to be appended to any
;            structure names to force them to be unique.
;
;   STRUCTURE_NAME - upon return, if the variable is a named
;                    structure, STRUCTURE_NAME will contain the name
;                    of the structure as a string.
;
;   NAMED_CLASSES /
;   NAMED_STRUCTS - upon input, this keyword should contain an
;                   undefined or a string array value.
;
;                   If the variable contains any named structure/class
;                   definitions, CMSV_RVTYPE will append those names
;                   upon return, including any enclosed structures or
;                   superclasses.
;
;   UNIT - a file unit.  If a library routine reads to the end of
;          BLOCK, or if BLOCK is undefined, then this file UNIT will
;          be accessed for more data.  If undefined, then BLOCK must
;          contain the entire file in memory.
;
;   OFFSET - the file offset of byte zero of BLOCK.  Default: 0
;            (OFFSET is not used by this routine at this time)
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added notification about RSI License, 13 May 2002, CM
;   Avoid using reserved word INHERITS, 07 Mar 2006, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_rvtype.pro,v 1.13 2009/11/22 22:50:49 craigm Exp $
;
;-
; Copyright (C) 2000-2001, 2002, 2006, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSV_TEST
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Test the CMSVLIB library
;
; CALLING SEQUENCE:
;   CMSV_TEST, FILENAME, USER_VALUE=UVALUE
;   
; DESCRIPTION: 
;
;   CMSV_TEST performs a standard test of the CMSVLIB library.  It
;   reads and writes a save file using several different methods in an
;   attempt to test the different ways that the library can be used.
;   The test procedure can be used to verify that the library is
;   functioning properly.
;
;   By default, this procedure provides standard values to be written,
;   but the user can provide one of them with the USER_VALUE keyword.
;   If the user's data contains pointers, they must expect tests
;   listed under CMSVREAD and CMSVWRITE to fail.
;
;   By default the file is written in the current directory, but this
;   can be changed with the FILENAME parameter.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; INPUTS:
;
;   FILENAME - a scalar string, the output path.  
;              Default: 'CMSVTEST.SAV' in current directory
;
; KEYWORDS:
;
;   USER_VALUE - any IDL variable to be saved, in place of variable
;                "C" in the test.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Resolve all routines at start, and add VMS keyword, 14 Feb 2001, CM
;   Make version checks with correct precision, 19 Jul 2001, CM
;   Added notification about RSI License, 13 May 2002, CM
;   Changed test so that 'DEADBEEF'XL is not used, which apparently
;     causes problems on 'FL', 01 Aug 2009
;   Add test for strings >127 characters (v1.7), 2012-04-05, CM
;
; $Id: cmsv_test.pro,v 1.11 2012/04/05 20:43:09 cmarkwar Exp $
;
;-
; Copyright (C) 2000-2001, 2009, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; print, '/-------------'
  cmsavedir, filename, status=status, errmsg=errmsg, n_var=nvar, $
    var_names=vnames, types=vtypes, /quiet
; print, '\-------------'
  if status EQ 0 then begin
      print, '  ** Failed to read file.  Error message follows:'
      message, errmsg, /info
  endif else begin
      if nvar NE 5 then $
        message, '  ** Incorrect number of variables'
      if vnames(0) NE 'A' OR vnames(1) NE 'B' OR vnames(2) NE 'C' $
        OR vnames(3) NE 'D' OR vnames(4) NE 'E' then $
        message, '  ** Variable names not correct'
      if total(size(a) NE vtypes(*,0)) NE 0 then $
        message, '  ** Variable "A" type incorrect'
      if total(size(b) NE vtypes(*,1)) NE 0 then $
        message, '  ** Variable "B" type incorrect'
      if total(size(c) NE vtypes(*,2)) NE 0 then $
        message, '  ** Variable "C" type incorrect'
      if total(size(d) NE vtypes(*,3)) NE 0 then $
        message, '  ** Variable "D" type incorrect'
      if total(size(e) NE vtypes(*,4)) NE 0 then $
        message, '  ** Variable "E" type incorrect'
      print, '  ** CMSAVEDIR succeeded'
  endelse

  print, ''
  print, 'Testing CMRESTORE'

  cmsv_test_unset, a, b, c, d, e
  print, '  Using IMPLICIT method...', format='(A,$)'
  cmrestore, filename, status=status, errmsg=errmsg
  if status EQ 0 then begin
      print, 'FAILED'
      message, errmsg, /info
  endif else begin
      cmsv_test_comp, a, b, c, d, e, result, failed
      if result EQ 0 then print, 'FAILED test '+failed $
      else print, 'succeeded'
  endelse

  cmsv_test_unset, a, b, c, d, e
  print, '  Using ARG method...', format='(A,$)'
  cmrestore, filename, a, b, c, d, e, status=status, errmsg=errmsg, $
    /quiet
  if status EQ 0 then begin
      print, 'FAILED'
      message, errmsg, /info
  endif else begin
      cmsv_test_comp, a, b, c, d, e, result, failed
      if result EQ 0 then print, 'FAILED test '+failed $
      else print, 'succeeded'
  endelse

  if ver GE 5D then begin
      cmsv_test_unset, a, b, c, d, e
      print, '  Using POINTER method...', format='(A,$)'
      cmrestore, filename, names=['A','B','C','D','E'], $
        status=status, errmsg=errmsg, data=data, pass_meth='POINTER', /quiet
      if status EQ 0 then begin
          print, 'FAILED'
          message, errmsg, /info
      endif else begin
          cmd = ('cmsv_test_comp, *(data(0)), *(data(1)), *(data(2)), '+ $
                 '*(data(3)), *(data(4)), result, failed')
          dummy = execute(cmd)
          if result EQ 0 OR dummy EQ 0 then print, 'FAILED test '+failed $
          else print, 'succeeded'
      endelse
      if total(ptr_valid(data)) GT 0 then $
        ptr_free, data
      
      cmsv_test_unset, a, b, c, d, e
      print, '  Using POINTER method with reversed names...', format='(A,$)'
      cmrestore, filename, names=['E','D','C','B','A'], $
        status=status, errmsg=errmsg, data=data, pass_meth='POINTER', /quiet
      if status EQ 0 then begin
          print, 'FAILED'
          message, errmsg, /info
      endif else begin
          cmd = ('cmsv_test_comp, *(data(4)), *(data(3)), *(data(2)), '+ $
                 '*(data(1)), *(data(0)), result, failed')
          dummy = execute(cmd)
          if result EQ 0 OR dummy EQ 0 then print, 'FAILED test '+failed $
          else print, 'succeeded'
      endelse
      if total(ptr_valid(data)) GT 0 then $
        ptr_free, data
  endif


  cmsv_test_unset, a, b, c, d, e
  print, '  Using STRUCT method...', format='(A,$)'
  cmrestore, filename, names=['A','B','C','D','E'], $
    status=status, errmsg=errmsg, data=data, pass_meth='STRUCT', /quiet, $
    version=cmrestore_version
  if status EQ 0 then begin
      print, 'FAILED'
      message, errmsg, /info
  endif else begin
      cmsv_test_comp, data.(0), data.(1), data.(2), data.(3), data.(4), $
        result, failed
      if result EQ 0 then print, 'FAILED test '+failed $
      else print, 'succeeded'
      print, '  ... using version '+cmrestore_version
  endelse


  print, ''
  print, 'Testing CMSAVE'
  cmsv_test_set, a, b, c, d, e
  print, '  Using ARG method...', format='(A,$)'
  cmsave, a, b, c, d, e, file=filename, status=status, errmsg=errmsg, $
    /quiet, compat=compat, version=cmsave_version
  if status EQ 0 then begin
      print, 'FAILED'
      message, errmsg, /info
  endif else begin
      restore, filename
      cmsv_test_comp, a, b, c, d, e, result, failed
      if result EQ 0 then print, 'FAILED test '+failed $
      else print, 'succeeded'
      print, '  ... using version '+cmsave_version
  endelse

  if ver GE 5D then begin
      cmsv_test_set, a, b, c, d, e
      print, '  Using POINTER method...', format='(A,$)'
      pheap = [ptr_new(a), ptr_new(b), ptr_new(c), ptr_new(d), ptr_new(e)]
      
      cmsave, file=filename, data=pheap, names=['A','B','C','D','E'], $
        status=status, errmsg=errmsg, /nocatch
      if status EQ 0 then begin
          print, 'FAILED'
          message, errmsg, /info
      endif else begin
          restore, filename
          cmsv_test_comp, a, b, c, d, e, result, failed
          if result EQ 0 then print, 'FAILED test '+failed $
          else print, 'succeeded'
      endelse
      if total(ptr_valid(pheap)) GT 0 then $
        ptr_free, pheap
  endif

  cmsv_test_set, a, b, c, d, e
  print, '  Using UNIT method...', format='(A,$)'
  cmsave, a, b, c, d, e, file=filename, /useunit, $
    status=status, errmsg=errmsg, /quiet, compat=compat
  if status EQ 0 then begin
      print, 'FAILED'
      message, errmsg, /info
  endif else begin
      restore, filename
      cmsv_test_comp, a, b, c, d, e, result, failed
      if result EQ 0 then print, 'FAILED test '+failed $
      else print, 'succeeded'
  endelse

  cmsv_test_set, a, b, c, d, e
  print, '  Using STRUCT method...', format='(A,$)'
  pheap = {a:a, b:b, c:c, d:d, e:e}
  cmsave, file=filename, data=pheap, $
    status=status, errmsg=errmsg, /quiet, compat=compat
  if status EQ 0 then begin
      print, 'FAILED'
      message, errmsg, /info
  endif else begin
      restore, filename
      cmsv_test_comp, a, b, c, d, e, result, failed
      if result EQ 0 then print, 'FAILED test '+failed $
      else print, 'succeeded'
  endelse

  get_lun, unit

  print, ''
  print, 'Testing CMSVREAD'
  cmsv_test_set, a, b, c, d, e
  sz = size(c)
  if sz(sz(0)+1) EQ 10 then $
    print, '  WARNING: data of type POINTER was found; expect failures!!'
  print, '  Saving template file...', format='(A,$)'
  save, a, b, c, d, e, file=filename
  print, 'done'

  openr, unit, filename, error=err
  if err NE 0 then begin
      print, '  ERROR: could not open '+filename
      return
  endif
  
  print, '  Reading file with CMSVREAD...', format='(A,$)'
  cmsvread, unit, a, name='A', /quiet
  cmsvread, unit, b, name='B', /quiet
  cmsvread, unit, c, name='C', /quiet
  cmsvread, unit, d, name='D', /quiet
  cmsvread, unit, e, name='E', /quiet, status=status
  close, unit
  free_lun, unit
  if status NE 1 then print, 'FAILED' $
  else                print, 'done'

  print, '  Checking results...', format='(A,$)'
  cmsv_test_comp, a, b, c, d, e, result, failed
  if result EQ 0 then print, 'FAILED test '+failed $
  else print, 'succeeded'

  print, ''
  print, 'Testing CMSVWRITE'
  openw, unit, filename, error=err, /STREAM   ;; STREAM for VMS
  if err NE 0 then begin
      print, '  ERROR: could not open '+filename
      return
  endif
  print, '  Writing file...', format='(A,$)'
  cmsv_test_set, a, b, c, d, e
  cmsvwrite, unit, a, name='A', /quiet, compat=compat
  cmsvwrite, unit, b, name='B', /quiet, /NO_END  ;; Test this keyword
  cmsvwrite, unit, c, name='C', /quiet, /NO_END
  cmsvwrite, unit, d, name='D', /quiet
  cmsvwrite, unit, e, name='E', /quiet, status=status
  close, unit
  if status NE 1 then print, 'FAILED' $
  else                print, 'done'
  print, '  Checking results...', format='(A,$)'
  cmsv_test_unset, a, b, c, d, e
  restore, filename
  cmsv_test_comp, a, b, c, d, e, result, failed
  if result EQ 0 then print, 'FAILED test '+failed $
  else print, 'succeeded'

end
;+
; NAME:
;   CMSV_WDATA
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Write SAVE-formatted data variable record to output block or file
;
; CALLING SEQUENCE:
;   CMSV_WDATA, BLOCK, POINTER, DATA, UNIT=UNIT, TEMPORARY=TEMPORARY, $
;               PTR_INDEX=PTR_INDEX, PTR_DATA=PTR_DATA, $
;               OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   CMSV_WDATA writes the data portion of an IDL SAVE variable record.
;   An IDL variable is stored in two components: the type descriptor
;   which describes the name, type, and dimensions of the variable;
;   and the data record, which contains the raw data of the variable.
;   This procedure writes the raw data to the output.  The initial
;   type descriptor portion of the record must have already been
;   writtenusing the CMSV_WVTYPE procedure.
;
;   Under normal circumstances a user will write variable or heap data
;   using the CMSV_WREC procedure.
;
;   CMSV_WDATA supports the following variable types:
;
;     BYTE(1),INT(2),LONG(3) - integer types
;     UINT(12),ULONG(13),LONG64(14),ULONG64(15) - integer types (IDL >5.2 only)
;     FLOAT(4),DOUBLE(5),COMPLEX(6),DCOMPLEX(9) - float types
;     STRING(7) - string type
;     STRUCT(8) - structure type
;     POINTER(10) - pointer type - SEE BELOW
;     NOT SUPPORTED - OBJ(11) - object reference type - NOT SUPPORTED
;
;   Arrays and structures containing any of the supported types are
;   supported (including structures within structures).
;
;   The caller must specify in the DATA parameter, the data to be
;   written to output.  The variable passed as DATA must have the same
;   type and dimensions as passed to CMSV_WVTYPE.
;
;   Unlike most of the other output routines, this procedure is able
;   to send its output to a file rather than to the BLOCK buffer.  If
;   the UNIT keyword is specified then output is sent to that file
;   UNIT, after any pending BLOCK data is first sent.  Users should
;   note that after such operations, the BLOCK POINTER and OFFSET
;   parameters may be modified (ie reset to new values).
;
;   See CMSV_WREC for instructions on how to write heap data.
;
;   [ This code assumes the record header and type descriptor have
;   been written with CMSV_WREC and CMSV_WVTYPE. ]
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
;
; BLOCK, POINTER, OFFSET
;
;   This procedure writes data to a byte array or a file.  If the UNIT
;   keyword is specified then file is sent to the specified unit
;   number rather than to the buffer BLOCK.  However, the intent is
;   for users to accumulate a significant amount of data in a BLOCK
;   and then write it out with a single call to WRITEU.  Users should
;   be aware that the block can be larger than the buffered data, so
;   they should use something like the following:
;
;          WRITEU, UNIT, BLOCK(0:POINTER-1)
;
;   When library routines do indeed write buffered BLOCK data to disk,
;   they will appropriately reset the BLOCK and POINTER.  Namely,
;   BLOCK will be reset to empty, and POINTER will be reset to zero.
;   OFFSET will be advanced the according number of bytes.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be read is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.  
;
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN or writing the
;           block to disk.
;
;   POINTER - a long integer, a pointer to the next byte to be read
;             from BLOCK.  CMSVLIB routines will automatically
;             advance the pointer.
;
;   DATA - the data to be written, of any save-able data type.
;
; KEYWORDS:
;
;   TEMPORARY - if set, then the input DATA are discarded after being
;               written, as a memory economy provision.
;
;   PTR_INDEX - a heap index array for the data being written, if any
;               heap data records have been written.
;               Default: no pointers are written
;
;   PTR_DATA - an array of pointers, pointing to the heap values being
;              written.
;              Default: no pointers are written
;
;   UNIT - a file unit.  If specified then data are directed to the
;          file unit rather than to the buffer BLOCK.
;
;   OFFSET - the file offset of byte zero of BLOCK.  
;            Upon output, if the file pointer is advanced, OFFSET will
;            also be changed.
;            (OFFSET is not currently used by this routine)
;            Default: 0
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added notification about RSI License, 13 May 2002, CM
;   Added support for byte scalars and arrays (!), 27 Mar 2006, CM
;   Bug fix for multi-dimensional byte array, 2013-04-18, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_wdata.pro,v 1.11 2013/04/18 19:14:08 cmarkwar Exp $
;
;-
; Copyright (C) 2000-2001, 2006, 2013, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; ---------------- Convert from host to network order ------------------
pro cmsv_wconv, data

  ;; Inspired by IDL Astronomy Library routine HOST_TO_IEEE
  common cmsv_conv_common, lendian
  if n_elements(lendian) EQ 0 then begin
      ;; Little-endian?
      lendian = (long(['01'xb,'02'xb,'03'xb,'04'xb],0,1))(0) NE '01020304'xl
  endif

  sz = size(data)
  case sz(sz(0)+1) of 
      1:  return                    ;; Byte
      2:  byteorder, data, /HTONS   ;; Integer
      3:  byteorder, data, /HTONL   ;; Long
      4:  byteorder, data, /FTOXDR  ;; Float
      5:  byteorder, data, /DTOXDR  ;; Double
      6:  byteorder, data, /FTOXDR  ;; Complex
      9:  byteorder, data, /DTOXDR  ;; DComplex
      12: byteorder, data, /HTONS   ;; UInt
      13: byteorder, data, /HTONL   ;; ULong
      14: if lendian EQ 1 then byteorder, data, /L64SWAP ;; LONG64
      15: if lendian EQ 1 then byteorder, data, /L64SWAP ;; ULONG64
      ELSE: 
  endcase

end

pro cmsv_wdata, block, pointer, value, unit=unit, temporary=temp, $
                ptr_index=pi, ptr_data=pd, start=start, $
                status=status, errmsg=errmsg

  ;; VAR_DATA
  ;;   LONG - START_DATA TOKEN - value 7
  ;;   for bytes - consecutive bytes
  ;;   for (u)ints - upcast to type long 
  ;;   for (u)longs - consecutive longs
  ;;   for pointers - consecutive longs, indices into saved heap data
  ;;   for strings - consecutive STRING's
  ;;   for structs - compacted versions of above
  forward_function byte, long, ulong, float, double, ptr_new

  data = 0
  if n_elements(start) EQ 0 then start = 1
  if n_elements(pointer) EQ 0 then pointer = 0L

  if keyword_set(start) then begin
      cmsv_wraw, /long, block, pointer, 7L, unit=unit, $
        status=status, errmsg=errmsg
      if status EQ 0 then return
  endif
  sz = size(value)
  tp = sz(sz(0)+1)
  if (tp EQ 11) then begin
      status = 0
      errmsg = 'ERROR: CMSV_WDATA: cannot write object data'
      return
  endif
  nelt = sz(sz(0)+2)

  if (tp EQ 8) then begin   ;; Structure type
      tn = tag_names(value(0)) & nt = n_elements(tn)

      for i = 0L, nelt-1 do begin
          for j = 0L, nt-1 do begin
              cmsv_wdata, block, pointer, value(i).(j), start=0, $
                status=status, errmsg=errmsg
              if status EQ 0 then return
          endfor

          ;; Occasionally flush the data to disk
          if keyword_set(start) AND n_elements(unit) GT 0 then begin
              if (i EQ nelt-1) OR (pointer GT 65536L) then begin
                  writeu, unit(0), block(0:pointer-1)
                  pointer = 0L
                  block = 0 & dummy = temporary(block)
              endif
          endif
      endfor

      return
  endif

  if tp EQ 7 then begin     ;; String type
      cmsv_wraw, /string, block, pointer, value, /replen, $
        status=status, errmsg=errmsg
      if status EQ 0 then return

      if (n_elements(unit) GT 0 AND keyword_set(start) $
          AND pointer GT 0) then begin
          writeu, unit(0), block(0:pointer-1)
          pointer = 0L
          block = 0 & dummy = temporary(block)
      endif
      return
  endif

  ;; Sometimes the input data is stored as a different type
  common cmsv_datatypes, stype, sbyte, nbyte, selts
  if n_elements(stype) EQ 0 then begin
      ;;      0      1       2       3        4        5         6    7   8
      ;;          byte     int    long    float    double   complex str struct
      stype =['','BYTE', 'LONG', 'LONG', 'FLOAT', 'DOUBLE', 'FLOAT', '', '' ]
      sbyte =[0,     1,      4,      4,       4,        8,       4,   0,  0 ]
      selts =[0,     1,      1,      1,       1,        1,       2,   0,  0 ]

      ;;                  9     10   11     12       13        14
      ;;            dcomplex   ptr   obj   uint     ulong    long64   ulong64
      stype =[stype,'DOUBLE', 'LONG', '', 'ULONG', 'ULONG', 'LONG64','ULONG64']
      sbyte =[sbyte,      8,     4,   0,     4,       4,        8,        8, 0]
      selts =[selts,      2,     1,   0,     1,       1,        1,        1, 0]
  endif

  status = 0
  nb = sbyte(tp<16)
  if nb EQ 0 then begin
      errmsg = 'ERROR: CMSV_WDATA: cannot write specified type ('+strtrim(tp,2)+')'
      return
  endif
  nelt1 = nelt*selts(tp<16)     ;; Account for complex type
  nb = nb*nelt1                 ;; Number of total bytes

  if keyword_set(temp) then data = temporary(value) $
  else                      data = value
  if sz(0) GT 0 then data = reform(data, /overwrite)
  
  ;; Convert from pointer type to LONG
  psz = size(pd)
  if (tp EQ 10) then begin
      odata = temporary(data)
      null = ptr_new()
      ;; Initialize as null pointers
      if sz(0) GT 0 then data = lonarr(nelt) else data = 0L

      ;; Fill in the pointers if we know about it
      if (n_elements(pi) GT 0) AND (n_elements(pi) EQ n_elements(pd)) $
        AND (psz(psz(0)+1) EQ 10) then begin
          for i = 0L, nelt-1 do if odata(i) NE null then begin
              wh = where(odata(i) EQ pd, ct)
              if ct GT 0 then begin
                  data(i) = abs(pi(wh(0)))
                  pi(wh(0)) = -pi(wh(0))
              endif
          endif
      endif
      odata = 0
  endif

  ;; Error handler returns zero and error condition
  on_ioerror, WRITE_ERROR
  if 0 then begin
      WRITE_ERROR:
      errmsg = 'ERROR: CMSV_WDATA: a write error occurred'
      return
  end

  ;; Special conversions
  if (tp EQ 1)  then begin
      ;; BYTE data type: make a special header which 
      ;; contains the number of bytes;  also, round 
      ;; the number of storage bytes up to the next
      ;; 4-byte word boundary.
      data1 = long(nelt)
      cmsv_wconv, data1
      data = [byte(data1,0,4),reform(data,nelt,/overwrite)]

      if nb MOD 4 NE 0 then data = [temporary(data), bytarr(4-(nb MOD 4))]
      nb = n_elements(data)
  endif else begin
      if (tp EQ 2)  then data = long(temporary(data))
      if (tp EQ 12) then data = ulong(temporary(data))
      if (tp EQ 6)  then data = float(temporary(data), 0, nelt1)
      if (tp EQ 9)  then data = double(temporary(data), 0, nelt1)
      cmsv_wconv, data
  endelse

  if n_elements(unit) GT 0 then begin
      ;; Write data to file directly
      if n_elements(pointer) GT 0 then begin
          writeu, unit(0), block(0:pointer-1)
          pointer = 0L
          block = 0 & dummy = temporary(block)
      endif
      writeu, unit(0), data
  endif else begin
      ;; Write data to byte buffer

      cmsv_wraw, block, pointer, byte(temporary(data), 0, nb), /byte, $
        status=status, errmsg=errmsg
  endelse

  on_ioerror, NULL

  status = 1
  return
end
;+
; NAME:
;   CMSV_WRAW
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Write raw SAVE data to output block
;
; CALLING SEQUENCE:
;   CMSV_WRAW, BLOCK, POINTER, DATA, UNIT=UNIT, $
;              STRING=STRING, LONG=LONG, BYTE=BYTE, TYPE=TYPE, $
;              OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   This procedure writes raw integer or string data to an IDL SAVE
;   block in memory.  This is the lowest level writing function in the
;   library, intended for developers who are investigating new and
;   existing SAVE file formats.
;
;   The data to be written is specified by the DATA parameter.  The
;   data must be of type BYTE, LONG or STRING, and the type is
;   determined automatically from the data itself.  [ The mnemonic
;   STRING LONG and BYTE keywords are accepted for programming clarity
;   but ignored. ]
;
;   This procedure accepts but currently ignores the UNIT keyword.  It
;   is the caller's responsibility to write the BLOCK data to disk
;   when appropriate.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
;
; BLOCK, POINTER, OFFSET
;
;   This procedure writes data to a byte array only.  The intent is
;   for users to accumulate a significant amount of data in a BLOCK
;   and then write it out with a single call to WRITEU.  Users should
;   be aware that the block can be larger than the buffered data, so
;   they should use something like the following:
;
;          WRITEU, UNIT, BLOCK(0:POINTER-1)
;
;   When library routines do indeed write buffered BLOCK data to disk,
;   they will appropriately reset the BLOCK and POINTER.  Namely,
;   BLOCK will be reset to empty, and POINTER will be reset to zero.
;   OFFSET will be advanced the according number of bytes.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be written is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.  
;
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN or writing the
;           block to disk.
;
;   POINTER - a long integer, a pointer to the next byte to be written
;             from BLOCK.  CMSVLIB routines will automatically advance
;             the pointer.
;
;   DATA - the data to be written.  Must of type STRING, BYTE or LONG.
;
;
; KEYWORDS:
;
;   LONG - ignored (to be used for clarity)
;   BYTE - ignored (to be used for clarity)
;   STRING - ignored (to be used for clarity)
;
;   UNIT - a file unit.  Currently ignored.
;
;   OFFSET - the file offset of byte zero of BLOCK.  
;            Upon output, if the file pointer is advanced, OFFSET will
;            also be changed.
;            (OFFSET is not currently used by this routine)
;            Default: 0
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added notification about RSI License, 13 May 2002, CM
;   Fixed bug in writing of empty strings, 28 Mar 2006, CM
;   Fixed bug when writing strings >128 characters, 2012-04-05, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_wraw.pro,v 1.9 2012/04/05 20:43:09 cmarkwar Exp $
;
;-
; Copyright (C) 2000-2001, 2006, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;     1: dummy = 1                                    ; byte
;     2: byteorder, value, /HTONS                     ; int 
      4: byteorder, value, /HTONL                     ; long
;     8: if lendian then byteorder, value, /L64SWAP   ; long64
      else:
  endcase

  block(pointer) = byte(temporary(value), 0, ntotbytes)

  pointer = pointer + ntotbytes
  status = 1
  return
end
;+
; NAME:
;   CMSV_WREC
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Write SAVE-formatted record header to output block or file
;
; CALLING SEQUENCE:
;   CMSV_WDATA, BLOCK, POINTER, DATA, IDENT, UNIT=UNIT, $
;               INITIALIZE=INITIALIZE, NO_DATA=NO_DATA, $
;               NO_TYPE=NO_TYPE, COMPATIBILITY=COMPAT, $
;               BLOCK_TYPE=BLOCK_TYPE, BLOCK_NAME=BLOCK_NAME,
;               NEXT_BLOCK=NEXT_BLOCK, $
;               [ ... EXTRA KEYWORDS ... ]
;               OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   This procedure writes most types of IDL SAVE record, including the
;   header and contents.  The header consists of four bytes at the
;   beginning of each record which indentifies the type and size of
;   the record.  This procedure also writes the contents of certain
;   records, as noted below.
;
;   Users can specify the block type by passing the BLOCK_TYPE or
;   BLOCK_NAME keywords.  The values listed in the following table are
;   supported.  CMSV_WREC writes the contents of essentially all
;   record types as well.  Some records do not contain any contents at
;   all (those entries marked with an [empty]) and thus require no
;   further processing.
;
;    BLOCK_TYPE      BLOCK_TYPE         WRITE RECORD CONTENTS WITH...
;
;       0         = 'START_MARKER'      [empty]
;       1         = 'COMMON_BLOCK'      [this procedure]
;       2         = 'VARIABLE'          [this procedure]
;       3         = 'SYSTEM_VARIABLE'   [this procedure]
;       6         = 'END_MARKER'        [empty]
;       10        = 'TIMESTAMP'         [this procedure]
;       12        = 'COMPILED'          no published procedure
;       13        = 'IDENTIFICATION'    [this procedure]
;       14        = 'VERSION'           [this procedure]
;       15        = 'HEAP_INDEX'        [this procedure]
;       16        = 'HEAP_DATA'         [this procedure]
;       17        = 'PROMOTE64'         [empty]
;       19        = 'NOTICE'            [this procedure]
;
;   For records that contain variable data, the external procedures
;   CMSV_WVTYPE and/or CMSV_WDATA may be used, however it is not
;   recommended, since the record header must finally be re-written by
;   the user.  Users can write the entire record with this procedure.
;
;   After issuing a POINT_LUN, or after writing the BLOCK to disk, the
;   block cache in BLOCK must be reset using the /INITIALIZE keyword.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; SPECIFIC RECORD TYPES
;
;   CMSV_WREC reads certain specific record types automatically based
;   on data passed in the DATA parameter.  
;
;   Records of type 'VARIABLE' (2), 'SYSTEM_VARIABLE' (3) and
;   'HEAP_DATA' (16) require both the DATA and IDENT parameters.  For
;   the first two record types, the IDENT parameter is the name of the
;   variable, as a scalar string.  Variable names should be valid IDL
;   variable names, uppercase, and have no embedded spaces.  For the
;   'HEAP_DATA' record type, the IDENT parameter is the heap index
;   value, as described below.  The DATA itself can be any supported
;   IDL variable type (as described in CMSV_WVTYPE).
;
;   For records that accept data in the form of a structure, as listed
;   below, the listed structure tag entries are optional.  If the user
;   does not provide a value, then a suitable default will be computed
;   by this procedure (listed in parentheses).
;
;   A record of type 'VERSION' (14) has the following structure:
;
;         { FORMAT_VERSION: 0L, $   ; Format version number of file (5)
;           ARCH: '', $             ; !VERSION.ARCH of creating host
;           OS: '', $               ; !VERSION.OS of creating host
;           RELEASE: '' }           ; !VERSION.RELEASE of creating host
;
;   A record of type 'TIMESTAMP' (10) has the following structure:
;
;          { SAVE_DATE: '', $  ; Date the save file was created (SYSTIME(0))
;            SAVE_USER: '', $  ; User name who  created file ('UNKNOWN')
;            SAVE_HOST: '' }   ; Host name that created file ('UNKNOWN')
;
;   Save files created by IDL version 4 do not contain a timestamp
;   record.  Under Unix this procedure will attempt to discover the
;   user and host names automatically.
;
;   A record of type 'IDENTIFICATION' (13) has the following
;   structure:
;
;          { AUTHOR: '', $  ; Author of SAVE file ('')
;            TITLE:  '', $  ; Title of SAVE file  ('')
;            IDCODE: '' }   ; Identifying code for SAVE file ('')
;
;   It appears that this record is not used in IDL version 5 or later.
;
;   A record of type 'COMMON_BLOCK' (1) defines a named common block
;   and its variables.  A common block descriptor consists of an array
;   of strings whose first element is the common block name, and whose
;   remaining elements are the common block variable names.  Thus, a
;   common block descriptor must have at least two elements.  No
;   variable data are stored with the common block definition.
;
;   When a record of type 'NOTICE' (19) defines a notice to be
;   included in the save file.  It is a structure with one field:
;   {TEXT: ''}, where TEXT is the text content of the notice.
;
;   A record of type 'HEAP_INDEX' (15) defines the heap index in a
;   SAVE file.  The heap index specifies a list of which heap
;   variables are stored in the current save file.  These indices are
;   simply numbers which identify each heap variable (i.e.,
;   "<PtrHeapVar2>" would have an index of 2).  The heap index can use
;   any numbers to identify the heap data; however it is required that
;   all index entries have corresponding heap data values.
;
; WRITING HEAP DATA
;
;   If your data contains heap data and/or pointers, then users must
;   take special care in writing their data.  Writing heap data is
;   actually more straightforward than reading it.  There are several
;   steps involved which can be summarized as followed: (1) take
;   inventory of HEAP data; (2) write HEAP_INDEX record; (3) write one
;   HEAP_DATA record for each heap variable; and (4) write any other
;   variables using the heap index.
;
;   (1) Take inventory of heap data.  Before writing any data to the
;       SAVE file, use the CMSV_PTRSUM procedure to discover all
;       pointer variables in the data set, like so:
;
;          cmsv_ptrsum, var, ptrlist
;
;       PTRLIST contains an array of any heap variables pointed to by
;       VAR (including structures or pointed-to variables).  If
;       multiple variables are to be written, then the inventory must
;       contain the union of all heap variables.
;
;   (2) Write a HEAP_INDEX record.  The heap index is an array of long
;       integers which identify the heap variables.  In principle it
;       doesn't matter which integers are used, however there must be
;       a one-to-one correspondence between the entries in the heap
;       index and the heap identifiers used in the next step.  In this
;       example a simple LINDGEN is used:
;
;           index = lindgen(n_elements(ptrlist))
;           cmsv_wrec, block, pointer, index, block_name='HEAP_INDEX', $
;             offset=offset
;
;   (3) Write one HEAP_DATA record for each heap variable.  Issue one
;       CMSV_WREC call for each entry in PTRLIST, as follows for the
;       ith heap variable:
;
;           cmsv_wrec, block, pointer, ptrlist(i), block_name='HEAP_DATA', $
;             ptr_index=index, ptr_data=ptrlist, offset=offset
;
;       Note that the PTR_INDEX and PTR_DATA keywords are required
;       because heap data may itself contain pointers.  The PTR_INDEX
;       and PTR_DATA keywords enable the CMSV_WREC procedure to write
;       appropriate descriptors when it encounters pointers.
;
;   (4) Write remaining data.  For the ith variable, use:
;
;          cmsv_wrec, block, pointer, var(i), name(i), block_name='VARIABLE',$
;             ptr_index=index, ptr_data=ptrlist, offset=offset
;
;       As above, using the PTR_INDEX and PTR_DATA keywords will allow
;       the CMSV_WREC procedure to write the appropriate data.
;
;
; BLOCK, POINTER, OFFSET
;
;   This procedure writes data to a byte array or a file.  If the UNIT
;   keyword is specified then file is sent to the specified unit
;   number rather than to the buffer BLOCK.  However, the intent is
;   for users to accumulate a significant amount of data in a BLOCK
;   and then write it out with a single call to WRITEU.  Users should
;   be aware that the block can be larger than the buffered data, so
;   they should use something like the following:
;
;          WRITEU, UNIT, BLOCK(0:POINTER-1)
;
;   When library routines do indeed write buffered BLOCK data to disk,
;   they will appropriately reset the BLOCK and POINTER.  Namely,
;   BLOCK will be reset to empty, and POINTER will be reset to zero.
;   OFFSET will be advanced the according number of bytes.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be read is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.  
;
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN or writing the
;           block to disk.
;
;   POINTER - a long integer, a pointer to the next byte to be read
;             from BLOCK.  CMSVLIB routines will automatically
;             advance the pointer.
;
;   DATA - the record contents to be written, as describe above.
;
;   IDENT - for record types 'VARIABLE' (2) and 'SYSTEM_VARIABLE' (3),
;           the name of the variable as a scalar string.  For record
;           type 'HEAP_DATA' (16), the heap index identifier as a
;           scalar long integer.
;
; KEYWORDS:
;
;   BLOCK_NAME - a scalar string specifying the record type, as
;                described above.  The BLOCK_TYPE keyword takes
;                precedence over BLOCK_NAME.
;
;   BLOCK_TYPE - a scalar integer specifying the record type, as
;                described above.
;
;   NEXT_BLOCK - if specified, the file offset of the next record
;                location.
;                Default: the offset will be computed automatically.
;
;   INITIALIZE - if the keyword is set, then the BLOCK is emptied and
;                the POINTER is reset before any new data is written.
;
;   NO_TYPE - if set, no type descriptor or data are written for
;             variable records.
;
;   NO_DATA - if set, no data are written for variable records.
;
;
;   TEMPORARY - if set, then the input DATA are discarded after being
;               written, as a memory economy provision.
;
;   PTR_INDEX - a heap index array for the data being written, if any
;               heap data records have been written.
;               Default: no pointers are written
;
;   PTR_DATA - an array of pointers, pointing to the heap values being
;              written.
;              Default: no pointers are written
;
;   UNIT - a file unit.  If specified then data are directed to the
;          file unit rather than to the buffer BLOCK.
;
;   OFFSET - the file offset of byte zero of BLOCK.  
;            Upon output, if the file pointer is advanced, OFFSET will
;            also be changed.
;            (OFFSET is not currently used by this routine)
;            Default: 0
;
;   COMPATIBILITY - a string, which describes the format to be used in
;          the output file.  Possible values are:
;
;                  'IDL4' - format of IDL version 4;
;                  'IDL5' - format of IDL versions 5.0-5.3;
;                  'IDL6' - not supported yet, for versions 5.4-above;
;                  'RIVAL1' - same as 'IDL5', plus a directory entry is
;                            written to the file.
;           Note that files written in IDL5 format may still be
;           readable by IDL v.4.
;           Default: 'IDL5'
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added notification about RSI License, 13 May 2002, CM
;   Added NOTICE record type, 09 Jun 2003, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_wrec.pro,v 1.10 2009/11/22 22:50:49 craigm Exp $
;
;-
; Copyright (C) 2000-2001, 2003, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; --------------------------- Read Notice --------------------

pro cmsv_wnotice, block, pointer, status=status, errmsg=errmsg, $
                  text=text, _EXTRA=extra

  ;; NOTICE
  ;;   STRING - notice text

  if n_elements(text) EQ 0 then text = ''

  cmsv_wraw, /string, block, pointer, strtrim(text,2), $
    status=status, errmsg=errmsg

  return
end


pro cmsv_wrec, block, pointer, data, name, unit=unit, offset=offset0, $
               initialize=init, finish=finish, no_data=nodata, no_type=notype,$
               block_type=blocktype, block_name=blockname, next_block=np, $
               compatibility=compat, $
               status=status, errmsg=errmsg, _EXTRA=extra

  common cmsave_block_names, block_ntypenames, block_typenames
  if n_elements(block_ntypenames) EQ 0 then begin
      cmsv_rrec, /qblocknames
  endif

  if keyword_set(init) then begin
      pointer = 0L
      block = 0 & dummy = temporary(block)
  endif
  if n_elements(pointer) EQ 0 then pointer = 0L
  
  if n_elements(blocktype) EQ 0 then begin
      wh = where(strupcase(blockname(0)) EQ block_typenames, ct)
      if ct EQ 0 then begin
          errmsg = 'ERROR: CMSV_WREC: block type '+blockname(0)+' is unknown'
          status = 0
          return
      endif
      blocktype = wh(0)
  endif

  ;; Store position of file pointer at beginning of record
  p0 = pointer
  
  rechead = lonarr(4)
  rechead(0) = long(floor(blocktype(0)))
  if n_elements(offset0) EQ 0 then offset = 0L $
  else                             offset = floor(offset0(0))

  ;; Default pointer to next block assumes no data in record
  if n_elements(np) GT 0 then rechead(1) = floor(np(0)) $
  else                        rechead(1) = offset + p0 + 4*4

  cmsv_wraw, /long, block, pointer, rechead, $
    status=status, errmsg=errmsg

  if status EQ 0 OR keyword_set(finish) then return

  p1 = pointer

  blockname = block_typenames(blocktype(0) < block_ntypenames)

  vdata = (blockname EQ 'VARIABLE' OR blockname EQ 'SYSTEM_VARIABLE' OR $
           blockname EQ 'HEAP_DATA')

  if vdata AND keyword_set(notype) then return

  case blockname of
      'COMMON_BLOCK': cmsv_wcomm, block, pointer, data, $
        status=status, errmsg
      'TIMESTAMP': cmsv_wstamp, block, pointer, $
        status=status, errmsg=errmsg, _EXTRA=data
      'VERSION': cmsv_wversion, block, pointer, compatible=compat, $
        status=status, errmsg=errmsg, _EXTRA=data
      'IDENTIFICATION': cmsv_wident, block, pointer, $
        status=status, errmsg=errmsg, _EXTRA=data
      'HEAP_INDEX': cmsv_wheap, block, pointer, data, $
        status=status, errmsg=errmsg
      'VARIABLE': cmsv_wvtype, block, pointer, data, name, $
        status=status, errmsg=errmsg
      'SYSTEM_VARIABLE': cmsv_wvtype, block, pointer, data, name, $
        status=status, errmsg=errmsg, /system
      'HEAP_DATA': cmsv_wvtype, block, pointer, data, name, $
        status=status, errmsg=errmsg, /heap
      ELSE: dummy = 1
  endcase        

  if status EQ 0 then return
  
  ;; If UNIT is specified then we write out the accumulated BLOCK data
  ;; up to this point.  CMSV_WDATA will write out its own data.
  if n_elements(unit) GT 0 AND pointer GT 0 then begin
      offset1 = offset
      unit1 = floor(unit(0))

      writeu, unit1, block(0:pointer-1)

      ;; Reinitialize state
      if n_elements(block) GT 65536L then begin
          ;; Clear the block if it is too large
          block = 0 & dummy = temporary(block)
          if n_elements(block) GT 0 then block(*) = 0
      endif
      offset = offset + pointer
      pointer = 0L
  endif

  ;; Write the variable data if it exists
  if vdata AND NOT keyword_set(nodata) AND n_elements(data) GT 0 then begin
      cmsv_wdata, block, pointer, data, unit=unit, $
        status=status, errmsg=errmsg, _EXTRA=extra
      if status EQ 0 then return
      if n_elements(unit1) GT 0 then $
        point_lun, -unit1, offset
  endif

  ;; Rewrite the record header using the new header.
  if pointer NE p1 AND n_elements(np) EQ 0 then begin
      rechead(1) = offset + pointer

      if n_elements(unit1) GT 0 then begin
          ;; Be careful: we have already written the record header to
          ;; disk, so we need to seek backwards, write the new header,
          ;; and then seek forwards again.
          point_lun, -unit1, offset2
          cmsv_wraw, /long, block1, 0L, rechead, $
            status=status, errmsg=errmsg
          if status EQ 0 then return
          point_lun, unit1, offset1+p0
          writeu, unit1, block1(0:15)
          point_lun, unit1, offset2

      endif else begin
          ;; It's easy if the data has not been written yet
          cmsv_wraw, /long, block, (p0+0), rechead, $
            status=status, errmsg=errmsg
          if status EQ 0 then return
      endelse
  endif

  status = 1
  return
end
;+
; NAME:
;   CMSV_WVTYPE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Write variable type information to output block
;
; CALLING SEQUENCE:
;   CMSV_WVTYPE, BLOCK, DATA, IDENT, $
;                HEAP=HEAP, SYSTEM=SYSTEM, UNIT=UNIT, $
;                OFFSET=OFFSET, STATUS=STATUS, ERRMSG=ERRMSG
;   
; DESCRIPTION: 
;
;   CMSV_WVTYPE writes the type portion of an IDL SAVE variable
;   record.  An IDL variable is stored in two components: the type
;   descriptor which describes the name, type, and dimensions of the
;   variable; and the data record, which contains the raw data of the
;   variable.  This procedure writes the type descriptor based on a
;   variable passed by the user.  Once the type descriptor has been
;   written, the data portion can be written using the CMSV_WDATA
;   procedure.
;
;   CMSV_WVTYPE should recognize and correctly output type descriptors
;   for all currently known IDL data types, except for object
;   references.  Type information is inferred from the DATA parameter
;   passed by the user.  
;
;   Heap data is a special case, since the data itself are stored
;   separately from the pointer in the SAVE file.  Three steps must be
;   satisfied: a HEAP_INDEX record must be written; a valid HEAP_DATA
;   record must be written containing a type descriptor (written with
;   this procedure) and the heap data; and the named pointer itself
;   must be written.
;
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; BLOCK, POINTER, OFFSET
;
;   This procedure writes data to a byte array only.  The intent is
;   for users to accumulate a significant amount of data in a BLOCK
;   and then write it out with a single call to WRITEU.  Users should
;   be aware that the block can be larger than the buffered data, so
;   they should use something like the following:
;
;          WRITEU, UNIT, BLOCK(0:POINTER-1)
;
;   When library routines do indeed write buffered BLOCK data to disk,
;   they will appropriately reset the BLOCK and POINTER.  Namely,
;   BLOCK will be reset to empty, and POINTER will be reset to zero.
;   OFFSET will be advanced the according number of bytes.
;
;   The terminology is as follows: BLOCK is a byte array which
;   represents a portion of, or an entire, IDL SAVE file.  The block
;   may be a cached portion of an on-disk file, or an entire in-memory
;   SAVE file.  POINTER is the current file pointer within BLOCK
;   (i.e., the next byte to be written is BLOCK[POINTER]).  Hence, a
;   POINTER value of 0 refers to the start of the block.  OFFSET is
;   the file offset of the 0th byte of BLOCK; thus "POINT_LUN,
;   OFFSET+POINTER" should point to the same byte as BLOCK[POINTER].
;   The following diagram shows the meanings for BLOCK, POINTER and
;   OFFSET schematically:
;
;
;                 0 <-  OFFSET  -> |
;   FILE          |----------------|------*--------|--------->
;
;   BLOCK                          |------*--------|
;                                  0      ^ POINTER
;     
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.  
;
;
; INPUTS:
;
;   BLOCK - a byte array, a cache of the SAVE file.  Users will
;           usually not access this array directly.  Users are advised
;           to clear BLOCK after calling POINT_LUN or writing the
;           block to disk.
;
;   POINTER - a long integer, a pointer to the next byte to be written
;             from BLOCK.  CMSVLIB routines will automatically advance
;             the pointer.
;
;   DATA - the data to be written, of any save-able data type.
;
;   IDENT - for variables, the name of the variable as a string; for
;           heap data, the heap index as an integer.
;
; KEYWORDS:
;
;   HEAP - if set, the data is treated as heap data, and IDENT must be
;          an integer heap index.
;
;   SYSTEM - if set, the data is assumed to be a system variable.
;
;   UNIT - a file unit.  Currently ignored.
;
;   OFFSET - the file offset of byte zero of BLOCK.  
;            Upon output, if the file pointer is advanced, OFFSET will
;            also be changed.
;            (OFFSET is not currently used by this routine)
;            Default: 0
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added notification about RSI License, 13 May 2002, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsv_wvtype.pro,v 1.14 2009/11/22 22:50:49 craigm Exp $
;
;-
; Copyright (C) 2000-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSVLIB
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Initialize the CMSVLIB save library
;
; CALLING SEQUENCE:
;   VALUE = CMSVLIB(/QUERY, VERSION=version)
;   
; DESCRIPTION: 
;
;   This function initializes the CMSVLIB library to read, write and
;   interrogate IDL save files.  Use the QUERY keyword to determine
;   whether the full CMSVLIB library is present.
;
;   The VERSION keyword allows the user to query the version number of
;   the CMSVLIB library.  The library version number will be returned
;   as a string of the form "X.Y" where X is the major version number
;   and Y is the minor version number.  Callers can use this version
;   number to decide whether this particular version of the library is
;   compatible with their usage.
;
;
;   The procedures in the library are:
;
;    High-level
;      CMSAVE - save variables to a save file
;      CMRESTORE - restore variables from a save file
;      CMSAVEDIR - list contents of a save file 
;      CMSVLIB (function) - this file
;
;    Mid-level  
;      CMSV_OPEN - open a save file for reading or writing
;      CMSVREAD - read non-pointer data from file
;      CMSVWRITE - write non-pointer data to file
;
;    Low-level
;      CMSV_RREC - read record from save file
;      CMSV_RVTYPE - read variable type information from file
;      CMSV_RDATA - read variable data from file
;      CMSV_WREC - write record to save file
;      CMSV_WVTYPE - write variable type information to file
;      CMSV_WDATA - write variable data to file
;
;    Utility
;      CMSV_RRAW (function) - read raw integer or string data from file
;      CMSV_WRAW - write raw integer or string data to file
;      CMSV_PTRSUM - create a heap data inventory
;      CMSV_TEST - test the library
;      TAGSIZE (function) - determine the types of all tags in a structure
;      HELPFORM (function) - create HELP-like string describing a variable
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.  
;
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; INPUTS:
;
;   None
;
; KEYWORDS:
;
;   QUERY - if set, determine whether the CMSVLIB library is
;           installed.  Function returns 1 upon success, 0 upon
;           failure.
;
;   VERSION - upon return, the VERSION keyword will be set to a string
;             describing the version number of the CMSVLIB library.
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   CMRESTORE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000
;   Documented, 24 Jan 2001
;   Added notification about RSI License, 13 May 2002, CM
;   Documented the VERSION keyword, 22 Nov 2009, CM
;
; LIBRARY MODIFICATIONS
;   1.0 - initial release
;   1.1 - 2003-06-28 - CMSV_RREC - added NOTICE record type
;   1.2 - 2006-03-07 - CMSV_RVTYPE - avoid reserved word INHERITS
;   1.3 - 2006-03-27 - CMSV_WDATA - add support to write bytes & empty
;         strings
;   1.4 - 2009-11-16 - CMSV_RREC - NEXTREC field is ULONG
;   1.5 - 2009-11-22 - CMSV_RDATA - clarify & speed some code
;   1.6 - 2010-01-11 - CMSV_RREC - read 64-bit files
;   1.7 - 2012-04-05 - CMSV_WRAW - writing strings >128 fixed
;   1.8 - 2013-04-18 - CMSV_WDATA - bug fix multi-dimensional byte array
    version = '1.8'  ;; NOTE: modify this when incrementing version number
;
; $Id: cmsvlib.pro,v 1.8 2013/04/18 19:14:09 cmarkwar Exp $
;
;-
; Copyright (C) 2000-2001, 2009, 2010, 2012, 2013, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSVREAD
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Read a single variable from an open SAVE file
;
; CALLING SEQUENCE:
;
;   CMSVREAD, UNIT, DATA [, NAME=NAME, /NO_DATA, VERSION=VERSION,
;                           TIMESTAMP=TIMESTAMP ]
;   
; DESCRIPTION: 
;
;   CMSVREAD reads a single IDL variable from an open IDL SAVE file.
;   The file should already have been opened as a normal file using
;   OPENR.
;
;   CMSVREAD is a simplified version of the CMSVLIB package, and as
;   such is not capable of reading heap data (pointers) or object
;   data.  Strings, structures, and all array types are supported.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; INPUTS:
;
;   UNIT - the open file unit.
;
;   DATA - a named variable, into which the new data is to be read.
;
; KEYWORDS:
;
;   NAME - upon output, the name of the saved variable is returned in
;          this keyword.  If a failure or end of file condition
;          occurs, name will be undefined upon return.
;
;   STRUCTURE_NAME - if the data to be read is a structure, upon
;                    output, this keyword will contain the name of the
;                    structure.  A value of '' indicates an anonymous
;                    structure.
;
;   SIZE - upon output, the SIZE type of the data is returned in this
;          keyword.
;
;   NO_DATA - if set, no data is read from the file, only the variable
;            name and type.
;
;   TIMESTAMP - after the first call to CMSVREAD on a newly opened
;               file, this keyword will contain the file timestamp
;               structure.
;
;   VERSION - after the first call to CMSVREAD on a newly opened file,
;             this keyword will contain the file version information,
;             if available.
;
;   QUIET - if set, error messages are not printed.
;           Default: an error causes errors to be printed with MESSAGE
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;   Read all variables from a file, and print help on them.
;
;   openr, 50, 'test.sav'
;   name = ''
;   while n_elements(name) GT 0 do begin   ;; EOF signalled by NAME undefined
;      cmsvread, 50, data, name=name
;      help, name, data
;   end
;   close, 50
;
; SEE ALSO:
;
;   CMSVWRITE, CMRESTORE, CMSAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written and documented, 11 Jan 2001, CM
;   Added notification about RSI License, 13 May 2002, CM
;   Remove support for undocumented AUTOPROMOTE64 keyword, 
;      11 Jan 2010, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsvread.pro,v 1.9 2010/01/11 08:58:13 craigm Exp $
;
;-
; Copyright (C) 2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSVWRITE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Write a single variable to an open SAVE file
;
; CALLING SEQUENCE:
;
;   CMSVWRITE, UNIT, DATA [ , NAME=NAME, COMPATIBILITY=COMPAT ]
;   
; DESCRIPTION: 
;
;   CMSVWRITE writes a single IDL variable to an open IDL SAVE file.
;   The file should already have been opened for writing as a normal
;   file using OPENW or OPENU.
;
;   CMSVWRITE is a simplified version of the CMSVLIB package, and as
;   such is not capable of writing heap data (pointers) or object
;   data, or structures that contain them.  Strings, structures, and
;   all array types are supported.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; INPUTS:
;
;   UNIT - the open file unit.
;
;   DATA - the data to be written.
;
; KEYWORDS:
;
;   NAME - the optional name of the variable to be written (must be a
;          valid variable name).
;          Default: CMSVWRITE automatically creates a valid name.
;  
;   COMPATIBILITY - a string, which describes the format to be used in
;          the output file.  Possible values are:
;
;                  'IDL4' - format of IDL version 4;
;                  'IDL5' - format of IDL versions 5.0-5.3;
;                  'IDL6' - not supported yet, for versions 5.4-above;
;                  'RIVAL1' - same as 'IDL5'
;           Note that files written in IDL5 format may still be
;           readable by IDL v.4.
;           Default: 'IDL5'
;
;   NO_END - a save file must terminate with an "end" record.  By
;            default, CMSVWRITE will append such a record after the
;            variable is written, and then rewind the file pointer.
;            The end record must be written after the last variable,
;            but is optional otherwise.  Set this keyword to disable
;            writing the end record (for performance reasons).
;
;   QUIET - if set, error messages are not printed.
;           Default: an error causes errors to be printed with MESSAGE
;
;   STATUS - upon return, this keyword will contain 1 for success and
;            0 for failure.
;
;   ERRMSG - upon return with a failure, this keyword will contain the
;            error condition as a string.
;
; EXAMPLE:
;
;   Write variables A, B, C and D to a file.
;
;   openw, 50, 'test.sav'       ;; Add /STREAM under VMS !
;   cmsvwrite, 50, a, name='a'
;   cmsvwrite, 50, b, name='b'
;   cmsvwrite, 50, c, name='c'
;   close, 50
;
; SEE ALSO:
;
;   CMSVREAD, CMRESTORE, CMSAVE, SAVE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written and documented, 11 Jan 2001, CM
;   Make version checks with correct precision, 19 Jul 2001, CM
;   Added notification about RSI License, 13 May 2002, CM
;   NOTE: remember to modify CMSVLIB.PRO when changing library!
;
; $Id: cmsvwrite.pro,v 1.12 2009/11/22 22:50:49 craigm Exp $
;
;-
; Copyright (C) 2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CMSYSTIME
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Compute seconds since Jan 1, 1970 and (Modified) Julian Days
;
; CALLING SEQUENCE:
;   TIMEVAL1 = CMSYSTIME(TIMEVAL0, ...)
;
; DESCRIPTION: 
;
;   CMSYSTIME serves two functions.  It computes the current time in a
;   fashion similar to the built-in IDL system function SYSTIME().  It
;   also can convert between various time representations and systems,
;   including a textual format.
;
;   The current time can be obtained by invoking CMSYSTIME with the
;   /NOW keyword (which is entirely equivalent to SYSTIME(1)).
;
;   The most substantial part of CMSYSTIME, which distinguishes it
;   from SYSTIME, is its ability to convert between different time
;   formats.  CMSYSTIME recognizes can recognize and convert between
;   time in seconds (seconds since Jan 1, 1970 [ = SEC ]) and days
;   (Julian days [ = JDAY ] or "Modified" Julian days [ = MJD = JDAY -
;   2400000.5 ]).  It can also recognize and convert between local and
;   GM time.  
;
;   CMSYSTIME takes maximum care to preserve the full numerical
;   precision of the time values.  It converts all values to double
;   precision and may return days and seconds with fractional parts.
;
;   CMSYSTIME can also represent any time textually, not just the
;   current time.  The following textual formats are supported:
;        DOW MMM DD hh:mm:ss YYYY              - (Default - same as SYSTIME)
;        DOW MMM DD YYYY hh:mm:ss.uuuuuu TTTTT - (/EXTENDED)
;   where DOW and MMM are the abbreviated day of week and month in
;   English, DD is the day of the month, YYYY is the year, hh:mm:ss is
;   the time in 24 hr military time, uuuuuu are additional
;   microseconds, TTTTT is the timezone offset (in +hhmm
;   representation).
;
;   CMSYSTIME accepts one parameter, the input time to be converted.
;   Unlike SYSTIME, the *function* of CMSYSTIME is governed by various
;   keywords, as summarized in the following table:
;
;   Converting from                       Converting to
;   ---------------                       -------------
;   JDAY - /FROM_JULIAN                   JDAY - /JULIAN
;   MJD  - /FROM_MJD                      MJD  - /MJD
;   SEC  - (Default)                      SEC  - /SECONDS
;   Current time - /NOW                   TEXT - (Default or /EXTENDED)
;
;   Local time - /FROM_LOCAL              Local time - /LOCAL
;   GM time - (Default)                   GM time - (Default)
;   
;   If no argument is specified, the default is to report the current
;   time textually in the GM time zone.  CMSYSTIME automatically
;   determines the local time zone.
;
; INPUTS:
;
;   TIMEVAL0 - input time, in seconds or days, as described above.
;              This value is ignored if the NOW keyword is set.  Array
;              values are allowed.
;
; KEYWORDS:
;
;   NOW - If set, TIMEVAL0 is ignored and the current time is used as
;         input.
;
;   FROM_JULIAN - If set, TIMEVAL0 is in Julian days.
;   FROM_MJD    - If set, TIMEVAL0 is in Modified Julian days (MJD).
;   FROM_LOCAL  - If set, TIMEVAL0 is in the local time zone.
;                 If no FROM_ keywords are set, the input is assumed
;                 to be seconds from Jan 1, 1970.
;
;   JULIAN  - If set, the input is converted to Julian days upon output.
;   MJD     - If set, the input is converted to MJD upon output.
;   SECONDS - If set, the input is converted to seconds from Jan
;             1, 1970 upon output.
;   LOCAL   - If set, the input is converted to the local time zone.
;             If no "destination" keywords are set, the output is
;             converted to textual representation.
;
;   EXTENDED - Convert to a textual representation with additional
;              information, as noted above.
;
;   TIMEZONE - Upon output, the timezone offset is returned in this
;              keyword.  The offset is time difference in seconds
;              between GM time and the local time, such that LOCALTIME
;              = GMTIME + TIMEZONE
;
; RETURNS:
;   The resulting converted time(s), either as a double precision
;   number or a string.
;
; EXAMPLE:
;   
;   The equivalent to SYSTIME(0)
;     IDL> print, systime(0) & print, cmsystime(/now, /local)
;     Wed Jul  5 12:10:46 2000
;     Wed Jul  5 12:10:46 2000
;
;   The equivalent to SYSTIME(1)
;     IDL> print, systime(1) & print, cmsystime(/now,/seconds)
;        9.6277750e+08
;        9.6277750e+08
;
;   Comparison between local and GM time zones (I live in the Eastern
;    US, daylight savings)
;     IDL> print, cmsystime(/now,/extended)
;     Wed Jul  5 2000 16:13:15.659000 -0400
;     IDL> print, cmsystime(/now,/local,/extended)
;     Wed Jul  5 2000 12:13:15.664000 -0400
;    
;   What day of the week was it 200 days ago?  (Note, there are 86400
;    seconds in one day)
;     IDL> today = cmsystime(/now,/seconds)
;     IDL> print, cmsystime(today-86400L*200, /local)
;     Sat Dec 18 12:17:52 1999
;    
;
; SEE ALSO:
;
;   SYSTIME, JULDAY, CALDAT
;
; MODIFICATION HISTORY:
;   Written, CM, 05 Jul 2000
;   Printed time zone is zero when LOCAL=0, CM, 21 Aug 2000
;   Corrected behavior of /MJD (Thanks to Marshall Perrin), 03 Jun
;     2002
;   Corrected local vs. UTC problem caused by fractional UTC seconds,
;     (thanks to J. Wolfe) CM, 28 Dec 2005
;   Corrected problem with Julian day arrays, (thanks to W. Landsman),
;     CM, 29 Dec 2005
;
;  $Id: cmsystime.pro,v 1.5 2005/12/29 18:07:48 craigm Exp $
;
;-
; Copyright (C) 2000,2002,2005, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Comput X MOD M, ensuring positive remainder
function cmsystime_xmod, x, m
  return, (((x MOD m) + m) MOD m)
end

;; Convert from MJD to YR/MO/DAY
pro cmsystime_mjd2ymd, mjd, yr, mo, da
  offset = 2400000.5D
  offset_int = floor(offset)         ;; Integer part of offset
  offset_fra = offset - offset_int   ;; Fractional part of offset
  nn = offset_fra + mjd
  jd_fra = cmsystime_xmod(nn+0.5D, 1D) - 0.5D
  nn = nn + offset_int - jd_fra
  nn = nn + (floor(floor((nn - 4479.5D)/36524.25D) * 0.75D + 0.5D)-37.D)
  
  yr = long(floor(nn/365.25D) - 4712.D)
  dd = floor(cmsystime_xmod(nn-59.25D, 365.25D))
  
  mo = floor(cmsystime_xmod( floor((dd+0.5D)/30.6D) + 2.D, 12.D ) + 1.D)
  da = floor(cmsystime_xmod(dd+0.5D, 30.6D) + 1.D ) + 0.5D + jd_fra
end

function cmsystime, arg0, now=now, extended=extended, $
                    local=local, from_local=from_local, $
                    julian=jul, from_julian=from_julian, $
                    mjd=mjd, from_mjd=from_mjd, $
                    seconds=seconds, timezone=timezone

  common cmsystime_common, cmsystime_timezone, cmsystime_months, $
    cmsystime_dow

  ;; Precompute names of days in week and month
  if n_elements(cmsystime_months) EQ 0 then begin
      cmsystime_months = ['Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', $
                          'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec']
      cmsystime_dow = ['Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat']
  endif

  ;; Starting epoch, expressed in MJD and Julian days
  MJD_1970 = 40587D
  JD_1970  = MJD_1970 + 2400000.5D

  ;; Figure the time zone automatically, the first time around
  if n_elements(cmsystime_timezone) EQ 0 then begin
      ;; The GM time, converted to MDY
      gmtime = systime(1)
      cltime = systime(0)
      gmfrac = gmtime MOD 86400
      gm_mjd = floor(gmtime-gmfrac)/86400D + MJD_1970
      cmsystime_mjd2ymd, gm_mjd, gm_yr, gm_mo, gm_da
      gm_da = round(gm_da)

      ;; The local time
      ltime = strtrim(str_sep(strcompress(cltime),' '),2)
      da = floor(long(ltime(2)))
      ltimes = double(str_sep(ltime(3), ':'))
      lfrac = ltimes(2) + 60D*(ltimes(1) + 60D*ltimes(0))

      ;; The timezone difference...
      tz = lfrac - gmfrac
      ;; ... but we must account for day wrap-around
      if      gm_da EQ da - 1 then tz = tz + 86400 $
      else if gm_da EQ da + 1 then tz = tz - 86400 $
      else if gm_da LT da     then tz = tz - 86400 $  ;; ...and month roll-over
      else if gm_da GT da     then tz = tz + 86400    ;; ...and month roll-over

      ;; Store the new value
      cmsystime_timezone = round(tz/60)*60  ;; Round to nearest minute
  endif
  timezone = cmsystime_timezone

  ;; Compute the timezone offset, depending on which way the
  ;; conversion will go.
  offset = 0D
  if keyword_set(from_local) then offset = offset - timezone
  if keyword_set(local)      then offset = offset + timezone

  ;; Extract the time value either from the clock, or from the user
  ;; parameter
  if keyword_set(now) then begin
      ;; From clock (GMT)
      NOW_TIME:
      arg = systime(1)
      if keyword_set(from_local) then offset = 0D

  endif else begin
      ;; From user parameter
      if n_elements(arg0) EQ 0 then goto, NOW_TIME
      arg = double(arg0)

      if keyword_set(from_mjd) then begin
          ;; Convert from MJD ... avoid loss of numerical precision
          if keyword_set(mjd) then return, arg + offset
          if keyword_set(jul) then return, arg + offset + (JD_1970-MJD_1970)

          ;; Convert to seconds
          arg = (arg - MJD_1970) * 86400D

      endif else if keyword_set(from_julian) then begin
          ;; Convert from JD ... avoid loss of numerical precision if poss.
          if keyword_set(mjd) then return, arg + offset - (JD_1970-MJD_1970)
          if keyword_set(jul) then return, arg + offset

          ;; Convert to seconds
          arg = (arg - JD_1970)  * 86400D

      endif
  endelse

  ;; Add timezone offset
  if offset NE 0 then arg = arg + offset
  if keyword_set(seconds) then return, arg
  if keyword_set(jul)     then return, (arg / 86400D) +  JD_1970
  if keyword_set(mjd)     then return, (arg / 86400D) + MJD_1970

  ;; Convert to MJD, from there to MDY
  mjd = floor(arg/86400D) + MJD_1970
  dsecs = arg-floor(arg/86400D)*86400D
  hr = floor(dsecs / 3600) & dsecs = dsecs - hr*3600
  mi = floor(dsecs / 60)   & dsecs = dsecs - mi*60
  se = dsecs
  cmsystime_mjd2ymd, mjd, yr, mo, da

  ;; Day of week is simple to calculate, assumes 13 May 2000 was a Sunday
  dow = cmsystime_xmod((floor(mjd) - 51678L), 7L)

  ;; Compute the string values, unfortunately on an individual basis
  n = n_elements(yr)
  result = strarr(n)
  if keyword_set(extended) then begin
      for i = 0L, n-1 do begin
          sei = floor(se(i))
          sef = floor((se(i) - sei)*1000000D)
          result(i) = string(cmsystime_dow(dow(i)), cmsystime_months(mo(i)-1),$
                             da(i), yr(i), hr(i), mi(i), sei, sef, $
                             format=('(A3," ",A3," ",I2," ",I4.4," ",' + $
                                     'I2.2,":",I2.2,":",I2.2,".",I6.6)'))
      endfor

      ;; Extended string value includes time zone offset
      if keyword_set(local) then tzz = timezone else tzz = 0L
      tzabs = abs(tzz)
      tzhr = floor(tzabs/3600)
      tzstring = string(tzhr, floor(tzabs - tzhr*3600), $
                        format='(I2.2,I2.2)')
      if tzz LT 0 then tzstring = ' -'+tzstring $
      else             tzstring = ' +'+tzstring
      result = result + tzstring

  endif else begin
      for i = 0L, n-1 do begin
          result(i) = string(cmsystime_dow(dow(i)), cmsystime_months(mo(i)-1),$
                             da(i), hr(i), mi(i), floor(se(i)), yr(i), $
                             format=('(A3," ",A3," ",I2," ",' + $
                                     'I2.2,":",I2.2,":",I2.2," ",I4.4)'))
      endfor
  endelse

  return, result
end

;+
; NAME:
;   CMUNIQUE_ID
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Return a unique ID string
;
; CALLING SEQUENCE:
;   ID = CMUNIQUE_ID([STRINGVAL])
;
; DESCRIPTION: 
;
;   CMUNIQUE_ID returns a "unique" 8 character identifier.
;   Programmers can use this routine to derive unique strings which
;   can be used to write files, etc.
;
;   Identifiers are "unique" in the sense that it is unlikely that two
;   identifiers in a given IDL session will coincide.  Thus the
;   identifier is useful for constructing temporary filenames and
;   other hash values.  User routines are encouraged to append other
;   identifying information to this string, such as a session id, a
;   hostname, or a process id number.
;
;   The identifier is computed from various sources of random
;   information.  Users may supply additional information to be
;   scrambled into the identifier by passing the FODDER parameter.
;   CMUNIQUE_ID will return a different identifier upon each call,
;   with or without the FODDER keyword.  It maintains an internal
;   sequence counter, and and also scrambles in the system time.
;   These practices should ensure that successive identifiers are
;   different from one another.
;
; INPUTS:
;
;   FODDER - Any scalar string value.  These values are used to
;            additionally scramble the identifier.
;
; KEYWORDS:
;
;   NONE
;
; RETURNS:
;   The 8-character identifier string.
;
; EXAMPLE:
;   
;   Print two distinct identifiers.
;     IDL> print, cmunique_id(), ' ', cmunique_id()
;     29C47600 79061C57
;
; SEE ALSO:
;
;   NONE
;
; MODIFICATION HISTORY:
;   Written, CM, 11 Jan 2001
;
; $Id: cmunique_id.pro,v 1.2 2001/01/13 04:08:30 craigm Exp $
;
;-
; Copyright (C) 2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CROSSPN
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   A version of CROSSP for efficient vector cross products
;
; CALLING SEQUENCE:
;   C = CROSSPN(A, B)
;
; DESCRIPTION: 
;
;   The function CROSSPN computes the vector cross product (outer
;   product).  The difference between CROSSPN and the IDL library
;   function CROSSP, is that CROSSPN allows more than one cross
;   product to be computed at one time (i.e., it is vectorized).
;
;   Thus, in the expression "C = CROSSPN(A, B)" the vector cross
;   product is computed as C = A x B.  Because CROSSPN is vectorized,
;   any of the following combinations are valid:
;
;       * A is a 3-vector, B is a 3-vector
;            ==> C is the vector cross product C = A x B
;
;       * A is a 3xN array, B is a 3-vector
;            ==> C(*,I) = A(*,I) x B    (each A is crossed with B)
;
;       * A is a 3-vector, B is a 3xN array
;            ==> C(*,I) = A x B(*,I)  (A is crossed with each B)
;
;       * A is a 3xN array, B is a 3xN array
;            ==> C(*,I) = A(*,I) x B(*,I)   (component-by-component)
;
;   If both A and B are arrays then they must have the same
;   dimensions.
;
; INPUTS:
;
;   A - a 3-vector or 3xN array.
;
;   B - a 3-vector or 3xN array.
;
;
; RETURNS:
;
;   The vector cross product A x B, either a 3-vector or a 3xN array
;   depending on A and B.
;
; SEE ALSO:
;
;   CROSSP
;
; MODIFICATION HISTORY:
;   Written, CM, 10 Mar 2002
;   Documented, CM, 22 Mar 2002
;
;  $Id: crosspn.pro,v 1.2 2002/03/22 22:02:02 craigm Exp $
;
;-
; Copyright (C) 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   CUBETERP
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Cubic spline interpolation with known derivatives
;
; MAJOR TOPICS:
;   Interpolation
;
; CALLING SEQUENCE:
;   CUBETERP, XTAB, YTAB, YPTAB, XINT, YINT, YPINT=, YPPINT=, EXTRAP_ORDER=
;
; DESCRIPTION:
;
;   CUBETERP performs cubic spline interpolation of a function.  This
;   routine is different from the many other spline interpolation
;   functions for IDL in that it allows you to choose the slope of the
;   spline at each control point.  I.e. it is not forced to be a
;   "natural" spline.
;
;   The user provides a tabulated set of data, whose (X,Y) positions
;   are (XTAB, YTAB), and whose derivatives are YPTAB.  The user also
;   provides a set of desired "X" abcissae for which interpolants are
;   requested.  The interpolated spline values are returned in YINT.
;   The interpolated curve will smoothly pass through the control
;   points, and have the requested slopes at those points.
;
;   The user may also optionally request the first and second
;   derivatives of the function with the YPINT and YPPINT keywords.
;
; INPUTS:
;
;   XTAB - tabulated X values.  Must be sorted in increasing order.
;
;   YTAB - tabulated Y values.
;
;   YPTAB - tabulated derivatives ( = dY/dX, evaluated at XTAB).
;
;   XINT - X values of desired interpolants.
;
; OUTPUTS:
;
;   YINT - Y values of desired interpolants.
;
; OPTIONAL KEYWORDS:
;
;   YPINT - upon return, the slope (first derivative) at the
;           interpolated positions.
;
;   YPPINT - upon return, the second derivative at the interpolated
;            positions.
;
;   EXTRAP_ORDER - technique used to extrapolate beyond the tabulated
;                  values.  Allowed values:
;                    -1 - extrapolated points are set to NaN (not a number)
;                     0 - constant extrapolation, equal to the value
;                         at the nearest tabulated point
;                     1 - linear extrapolation, based on slope at
;                         nearest tabulated value
;                     2 - quadratic extrapolation, based on slope and
;                         second derivative at nearest tabulated value
;                     3 - cubic extrapolation.
;                  DEFAULT: 2 (quadratic extrapolation)
;
;
; EXAMPLE:
;
;  ;; Set up some fake data
;  xtab = [0D,2,5,10]
;  ytab = [2D,4,-3,-5]
;  yptab = [-1D,0.5,2.3,-4]
;
;  ;; Interpolate to a finer grid
;  xint = dindgen(1001)/100
;  cubeterp, xtab, ytab, yptab, xint, yint
;
;  ;; Plot it
;  plot, xint, yint
;  oplot, xtab, ytab, psym=1, symsize=2
;  for i = 0, n_elements(xtab)-1 do $   ;; Also plot slopes
;    oplot, xtab(i)+[-0.5,0.5], ytab(i)+[-0.5,0.5]*yptab(i)
; 
;
; MODIFICATION HISTORY:
;   Written and documented, CM, July 2003
;   Added EXTRAP_ORDER = -1 option, CM, 15 May 2005
;   Syntax error fix, CM, 07 Mar 2007
;   Clarified documentation a bit, CM, 12 Nov 2007
;   Small documentation changes, CM, 16 Apr 2009
;
;  $Id: cubeterp.pro,v 1.8 2009/05/05 04:59:57 craigm Exp $
;
;-
; Copyright (C) 2003, 2005, 2007, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; Cubic interpolation with known slopes


pro cubeterp, xtab, ytab, yptab, xint, yint, $
              extrap_order=extr0, $
              ypint=ypint, yppint=yppint

  ntab = n_elements(xtab)
  if n_elements(extr0) EQ 0 then extr = 2 else extr = round(extr0(0))

  if n_elements(xtab) EQ 0 OR n_elements(ytab) EQ 0 then begin
      message, 'ERROR: XTAB and YTAB must be passed'
  endif
  if (n_elements(xtab) NE n_elements(ytab) OR $
      n_elements(xtab) NE n_elements(yptab)) then begin
      message, 'ERROR: Number of elements of XTAB, YTAB and YPTAB must agree'
  endif
  if n_elements(xint) EQ 0 then begin
      message, 'ERROR: XINT must be passed'
  endif

  ;; Locate previous tabulated value
  ii = value_locate(xtab, xint)

  ;; Here we make a safety check, in case the desired point(s) is
  ;; above or below the interior of the interpolation range.  In that
  ;; case, we will need to extrapolate, based on the next nearest
  ;; interval.
  iis = ii
  whll = where(ii LT 0, ctll)
  if ctll GT 0 then iis(whll) = iis(whll) + 1
  whgg = where(ii GE (ntab-1), ctgg)
  if ctgg GT 0 then iis(whgg) = iis(whgg) - 1

  ;; Distance from interpolated abcissae to previous tabulated abcissa
  dx = (xint - xtab(iis))
  
  ;; Distance between adjoining tabulated abcissae and ordinates
  xs = xtab(iis+1) - xtab(iis)
  ys = ytab(iis+1) - ytab(iis) 

  ;; Rescale or pull out quantities of interest
  dx = dx/xs               ;; Rescale DX
  y0 = ytab(iis)           ;; No rescaling of Y - start of interval
  y1 = ytab(iis+1)         ;; No rescaling of Y - end of interval
  yp0 = yptab(iis)*xs      ;; Rescale tabulated derivatives - start of interval
  yp1 = yptab(iis+1)*xs    ;; Rescale tabulated derivatives - end of interval

  ;; Compute polynomial coefficients
  a = y0
  b = yp0
  c = 3*ys - 2*yp0 - yp1
  d = yp0 + yp1 - 2*ys

  ;; Extrapolate only quadratically
  if extr EQ 2 then begin
      if ctll GT 0 then begin
          ;; Lower end of extrapolation
          d(whll) = 0
      endif
      if ctgg GT 0 then begin
          ;; Upper end of extrapolation
          dgg = d(whgg)
          a(whgg) = a(whgg) + dgg
          b(whgg) = b(whgg) - 3*dgg
          c(whgg) = c(whgg) + 3*dgg
          d(whgg) = 0
      endif
  endif

  ;; Extrapolate only linearly
  if extr EQ 1 then begin

      if ctll GT 0 then begin
          ;; Lower end of extrapolation
          c(whll) = 0
          d(whll) = 0
      endif
      if ctgg GT 0 then begin
          ;; Upper end of extrapolation
          dgg = d(whgg)
          cgg = c(whgg)
          a(whgg) = a(whgg) - cgg - 2*dgg
          b(whgg) = b(whgg) + 2*cgg + 3*dgg
          c(whgg) = 0
          d(whgg) = 0
      endif
  endif

  if extr EQ 0 then begin
      if ctll GT 0 then begin
          ;; Lower end of extrapolation
          b(whll) = 0
          c(whll) = 0
          d(whll) = 0
      endif
      if ctgg GT 0 then begin
          ;; Upper end of extrapolation
          a(whgg) = a(whgg) + b(whgg) + c(whgg) + d(whgg)
          b(whgg) = 0
          c(whgg) = 0
          d(whgg) = 0
      endif
  endif      

  if extr EQ -1 then begin
      sz = size(y0) & tp = sz(sz(0)+1)
      if sz EQ 4 OR sz EQ 6 then nanv = !values.f_nan $
      else nanv = !values.d_nan

      if ctll GT 0 then begin
          ;; Lower end of extrapolation
          a(whll) = nanv
      endif
      if ctgg GT 0 then begin
          ;; Upper end of extrapolation
          a(whgg) = nanv
      endif
  endif

  yint = a + dx*(b + dx*(c + dx*d))

  ;; Compute derivatives if requested
  if arg_present(ypint) then ypint = (b + dx*(2*c + dx*3*d))/xs
  if arg_present(yppint) then yppint = (2*c + 6*d*dx)/xs^2


  return
end
;+
; NAME:
;   DDEABM
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Integrate Ordinary Differential Equation with Adams-Bashforth-Moulton
;
; MAJOR TOPICS:
;   Numerical Analysis.
;
; CALLING SEQUENCE:
;   DDEABM, FUNCT, T0, F0, TOUT, [ PRIVATE, FUNCTARGS=, STATE= , ]
;     [ /INIT, /INTERMEDIATE, TSTOP=, EPSREL=, EPSABS=, ]
;     [ TGRID=, YGRID=, YPGRID=, NOUTGRID=, NGRID=, NFEV=, ]
;     [ TIMPULSE=, YIMPULSE=, ]
;     [ MAX_STEPSIZE=, /CONTROL, ]
;     [ STATUS=, ERRMSG= ]
;
; DESCRIPTION:
;
;  DDEABM performs integration of a system of one or more ordinary
;  differential equations using a Predictor-Corrector technique.  An
;  adaptive Adams-Bashforth-Moulton method of variable order between
;  one and twelve, adaptive stepsize, and error control, is used to
;  integrate equations of the form:
;
;     DF_DT = FUNCT(T, F)
;
;  T is the independent variable, F is the (possibly vector) function
;  value at T, and DF_DT is the derivative of F with respect to T,
;  evaluated at T.  FUNCT is a user function which returns the
;  derivative of one or more equations.  
;
;  DDEABM is based on the public domain procedure DDEABM.F written by
;  L. F. Shampine and M. K. Gordon, and available in the DEPAC package
;  of solvers within SLATEC library.
;
;  DDEABM is used primarily to solve non-stiff and mildly stiff
;  ordinary differential equations, where evaluation of the user
;  function is expensive, or high precision is demanded (close to the
;  machine precision).  A Runge-Kutta technique may be more
;  appropriate if lower precision is acceptable.  For stiff problems
;  neither Adams-Bashforth-Moulton nor Runge-Kutta techniques are
;  appropriate.  DDEABM has code which detects the stiffness of the
;  problem and reports it.
;
;  The user can operate DDEABM in three different modes:
;
;    * the user requests one output at a specific point (the default),
;      and maintains the integrator state using the STATE keyword;
;
;    * the user requests a grid of points (by passing an array to
;      TOUT), and optionally maintains the integrator state for
;      subsequent integrations using the STATE keyword;
;
;    * the user requests output at the natural adaptive stepsizes
;      using the /INTERMEDIATE keyword.
;
;  When the user requests explicit output points using TOUT, it is
;  likely that the output will be interpolated between two natural
;  stepsize points.
;
;  If the user requests a grid of outputs, and the integration fails
;  before reaching the requested endpoint, then control returns
;  immediately to the user with the appropriate STATUS code.
;
;  The initial conditions are given by F0, when T = T0.  The number of
;  equations is determined by the number of elements in F0.
;  Integration stops when the independent variable T reaches the final
;  value of TOUT.  If the user wants to continue the integration, it
;  can be restarted with a new call to DDEABM, and a new value of
;  TOUT.
;
; USER FUNCTION
;
;  The user function FUNCT must be of the following form:
;
;  FUNCTION FUNCT, T, F, PRIVATE, ...  [ CONTROL=CONTROL ] ...
;     ; ... compute derivatives ...
;     RETURN, DF_DT
;  END
;
;  The function must accept at least two, but optionally three,
;  parameters.  The first, 'T', is the scalar independent variable
;  where the derivatives are to be evaluated.  The second, 'F', is the
;  vector of function values.  The function must return an array of
;  same size as 'F'.  The third positional parameter, 'PRIVATE', is a
;  purely optional PRIVATE parameter.  FUNCT may accept more
;  positional parameters, but DDEABM will not use them.  Any number of
;  keyword parameters can be passed using the FUNCTARGS keyword.
;
;  The user function FUNCT must not modify either the independent
;  variable 'T' or the function values 'F'.
;
; PASSING 'CONTROL' MESSAGES TO THE USER FUNCTION
;
;  DDEABM may pass control information to the user function, other
;  than requests for function evaluation.  DDEABM will only do this if
;  the /CONTROL keyword is set when DDEABM was invoked.
;
;  When control information has been enabled, the user function *must*
;  accept a keyword named CONTROL.  A message may be passed in this
;  keyword.  If the user function is invoked with the CONTROL keyword
;  defined, the user function should not evaluate the function, but
;  rather it must respond to the message and return the appropriate
;  value.
;
;  The CONTROL message will be a structure of the form,
;     { MESSAGE: 'name', ... }
;  where the MESSAGE field indicates a control message.  Additional
;  fields may carry more information, depending on the message.
;
;  The following control messages are implemented:
;    * { MESSAGE: 'INITIALIZE' } - the integrator has been initialized
;      and the user function may also initialize any state variables,
;      load large data tables, etc.
;      RETURN: 0 for success, negative number to indicate failure.
;
;  If the user function does not recognize a message, a value of 0
;  should be returned.
;
;
; RESTARTING THE INTEGRATOR
;
;  When restarting the integrator, the STATE keyword can be used to
;  save some computation time.  Upon return from DDEABM the STATE
;  keyword will contain a structure which describes the state of the
;  integrator at the output point.  The user need merely pass this
;  variable back into the next call to continue integration.  The
;  value of T, and the function value F, must not be adjusted between
;  calls to DDEABM.
;
;  If T or F0 are to be adjusted, then the integrator must be
;  restarted afresh *without* the previous state.  This can be
;  achieved either by reseting STATE to undefined, or by setting the
;  /INIT keyword to DDEABM.
;
; ERROR CONTROL
;
;  Local error control is governed by two keywords, EPSABS and EPSREL.
;  The former governs the absolute error, while the latter governs the
;  relative or fractional error.  The error test at each iteration is:
;
;     ABS(ERROR)   LE   EPSREL*ABS(F) + EPSABS
;  
;  A scalar value indicates the same constraint should be applied to
;  every equation; a vector array indicates constraints should be
;  applied individually to each component.
;
;  Setting EPSABS=0.D0 results in a pure relative error test on that
;  component. Setting EPSREL=0. results in a pure absolute error test
;  on that component.  A mixed test with non-zero EPSREL and EPSABS
;  corresponds roughly to a relative error test when the solution
;  component is much bigger than EPSABS and to an absolute error test
;  when the solution component is smaller than the threshold EPSABS.
;  
;  Proper selection of the absolute error control parameters EPSABS
;  requires you to have some idea of the scale of the solution
;  components.  To acquire this information may mean that you will
;  have to solve the problem more than once. In the absence of scale
;  information, you should ask for some relative accuracy in all the
;  components (by setting EPSREL values non-zero) and perhaps impose
;  extremely small absolute error tolerances to protect against the
;  danger of a solution component becoming zero.
;  
;  The code will not attempt to compute a solution at an accuracy
;  unreasonable for the machine being used.  It will advise you if you
;  ask for too much accuracy and inform you as to the maximum accuracy
;  it believes possible.
;
; HARD LIMIT ON T
;
;  If for some reason there is a hard limit on the independent
;  variable T, then the user should specify TSTOP.  For efficiency
;  DDEABM may try to integrate *beyond* the requested point of
;  termination, TOUT, and then interpolate backwards to obtain the
;  function value at the requested point.  If this is not possible
;  because the function because the equation changes, or if there is a
;  discontinuity, then users should specify a value for TSTOP; the
;  integrator will not go past this point.
;
; DISCONTINUITIES
;
;  If the ODE or solution has discontinuities at known points, these
;  should be passed to DDEABM in order to aid the solution.  The
;  TIMPULSE and YIMPULSE keyword variables allow the user to identify
;  the positions of the discontinuities and their amplitudes.  As T
;  crosses TIMPULSE(i) the solution will change from Y to
;  Y+YIMPULSE(*,i) in a stepwise fashion.  
;
;  Discontinuities in the function to be integrated can also be
;  entered in this way.  Although DDEABM can adapt the integration
;  step size to accomodate changes in the user function, it may be
;  better to identify such discontinuities.  In that case TIMPULSE(i)
;  should still identify the position of discontinuity, and
;  YIMPULSE(*,i) should be 0.
;
;  Currently this functionality is implemented with restarts of the
;  integrator at the crossing points of the discontinuities.
;
;  This technique handles only discontinuities at explicitly known
;  values of T.  If the discontinuity condition is defined in terms of
;  Y  (or Y and T), then the condition is implicit.  DDEABM does not
;  handle that type of condition.
;
;  You may list the TIMPULSE points in the TOUT output grid.  If an
;  impulse point appears once in TOUT, the corresponding function
;  values reported in YGRID and YPGRID will be from *before* crossing
;  the discontinuity.  If the same TIMPULSE point appears *twice* in
;  TOUT, then the first and second values will correspond to before
;  and after crossing the discontinuity, respectively.
;
;
; INPUTS:
;
;  FUNCT - by default, a scalar string containing the name of an IDL
;          function to be integrated.  See above for the formal
;          definition of FUNCT.  (No default).
;
;  T0 - scalar number, upon input the starting value of the
;       independent variable T.  Upon output, the final value of T.
;
;  Y - vector.  Upon input the starting values of the function for T =
;      T0.  Upon output, the final (vector) value of the function.
;
;  TOUT - must be at least a scalar, but optionally a vector,
;         specifies the desired points of output.
;
;         If TOUT is a scalar and INTERMEDIATE is not set, then DDEABM
;         integrates up to TOUT.  A scalar value of the function at
;         TOUT is returned in F.
;
;         If TOUT is a scalar and /INTERMEDIATE is set, then DDEABM
;         computes a grid of function values at the optimal step
;         points of the solution.  The grid of values is returned in
;         TGRID, YGRID, and YPGRID.  The final function value,
;         evaluated at the last point in TOUT, is returned in F.
;
;         If TOUT is a vector, then DDEABM computes a grid of function
;         values at the requested points.  The grid of values is
;         returned in TGRID, YGRID and YPGRID.  The final function
;         value, evaluated at the last point in TOUT, is returned in
;         F.  If integrating forwards (TOUT greater than T0), TOUT
;         must be strictly increasing.  Generally speaking, TOUT
;         output points should not repeat, except for discontinuities
;         as noted above.
;
;         It is possible for TOUT to be less than T0, i.e., to
;         integrate backwards, in which case TOUT must be strictly
;         decreasing instead.
; 
;  PRIVATE - any optional variable to be passed on to the function to
;            be integrated.  For functions, PRIVATE is passed as the
;            second positional parameter.  DDEABM does not examine or
;            alter PRIVATE.
;
; KEYWORD PARAMETERS:
;
;   CONTROL - if set, then control messages will be set to the user
;             function as described above.  If not set, then no
;             control messages will be passed.
;
;   EPSABS - a scalar number, the absolute error tolerance requested
;            in the integral computation.  If less than or equal to
;            zero, then the value is ignored.
;            Default: 0
;
;   EPSREL - a scalar number, the relative (i.e., fractional) error
;            tolerance in the integral computation.  If less than or
;            equal to zero, then the value is ignored.
;            Default: 1e-4 for float, 1d-6 for double
;
;   ERRMSG - upon return, a descriptive error message.
;
;   FUNCTARGS - A structure which contains the parameters to be passed
;               to the user-supplied function specified by FUNCT via
;               the _EXTRA mechanism.  This is the way you can pass
;               additional data to your user-supplied function without
;               using common blocks.  By default, no extra parameters
;               are passed to the user-supplied function.
;
;   INIT - if set, indicates that the integrator is to be restarted
;          afresh.
;
;   INTERMEDIATE - if set, indicates that the integrator is to compute
;                  at the natural step points.
;
;   MAX_STEPSIZE - a positive scalar value, the maximum integration
;                  step size to take per iteration.  The lesser of the
;                  "natural" step size and MAX_STEPSIZE is used.  If
;                  MAX_STEPSIZE is not specified, there is no maximum.
;
;   NFEV - upon output, the scalar number of function evaluations.
;
;   NGRID - if /INTERMEDIATE is set, the requested number of points to
;           compute before returning.  DDEABM uses this value to
;           allocate storage for TGRID, YGRID, and YPGRID.  Note that
;           DDEABM may not actually calculate this many points.  The
;           user must use NOUTGRID upon return to determine how many
;           points are valid.
;           Default: 1
;
;   NOUTGRID - upon output, the number of grid points computed.  This
;              may be smaller than the requested number of grid points
;              (either via NGRID or TOUT) if an error occurs.
;
;   STATE - upon input and return, the integrator state.  Users should
;           not modify this structure.  If the integrator is to be
;           restarted afresh, then the /INIT keyword should be set, in
;           order to clear out the old state information.
;
;   STATUS - upon output, the integer status of the integration.
;
;           1 - A step was successfully taken in the
;               intermediate-output mode.  The code has not yet
;               reached TOUT.
; 
;           2 - The integration to TOUT was successfully completed
;               (T=TOUT) by stepping exactly to TOUT.
; 
;           3 - The integration to TOUT was successfully completed
;               (T=TOUT) by stepping past TOUT.  Y(*) is obtained by
;               interpolation.
; 
;                       *** Task Interrupted ***
;                 Reported by negative values of STATUS
; 
;           -1 - A large amount of work has been expended.  (500 steps
;                attempted)
; 
;           -2 - The error tolerances are too stringent.
; 
;           -3 - The local error test cannot be satisfied because you
;                specified a zero component in EPSABS and the
;                corresponding computed solution component is zero.
;                Thus, a pure relative error test is impossible for
;                this component.
; 
;           -4 - The problem appears to be stiff.
; 
;                       *** Task Terminated ***
; 
;           -33 - The code has encountered trouble from which it
;                 cannot recover.  A error message is printed
;                 explaining the trouble and control is returned to
;                 the calling program. For example, this occurs when
;                 invalid input is detected.
;
;           -16 - The user function returned a non-finite 
;
;   TGRID - upon output, the grid of values of T for which the
;           integration is provided.  Upon return, only values
;           TGRID(0:NOUTGRID-1) are valid.  The remaining values are
;           undefined.
;
;   TIMPULSE - array of values of T where discontinuities occur.  The
;              array should be in ascending order.  TIMPULSE must
;              match YIMPULSE.
;
;   TSTOP - a scalar, specifies a hard limit for T, beyond which the
;           integration must not proceed.
;           Default:  none, i.e., integration is allowed to
;                    "overshoot"
;
;   YGRID - upon output, the grid of function values for which the
;           integration is provided.  Upon return, only values
;           YGRID(*,0:NOUTGRID-1) are valid.  The remaining values are
;           undefined.
;
;   YIMPULSE - array of discontinuity offset values, of the form
;              DBLARR(NEQ,NIMPULSE), where NEQ is the size of Y and
;              NIMPULSE is the size of TIMPULSE.  YIMPULSE(*,I) is the
;              amount to *add* to Y when T crosses TIMPULSE(I) going
;              in the positive direction.
;
;   YPGRID - upon ouptut, the grid of function derivative values at
;            the points where the integration is provided.  Upon
;            return, only values YPGRID(*,0:NOUTGRID-1) are valid.
;            The remaining values are undefined.
;
; EXAMPLES:
;
;  This is a simple example showing how to computes orbits of a
;  satellite around the earth using Newton's law of gravity.  The
;  earth is assumed to be a central point mass, modeled by the
;  NEWTON_G function which follows.  We assume that the satellite is
;  orbiting at a radius of 7000 km.  The state vector F has six
;  elements consisting of the position and velocity of the satellite.
;
;           POSITION    VELOCITY
;     F = [ X, Y, Z,    VX, VY, VZ]
;
;  The function NEWTON_G below computes the derivative of F, that is,
;
;               VELOCITY       ACCELERATION
;     dF_dt = [ VX, VY, VZ,    AX, AY, AZ]
;
;  Where the acceleration vector [AX,AY,AZ] is computed using Newton's
;  laws.
;
;  GM = 3.986005d14 ; [MKS] - gravitational constant for earth
;  
;  a0 = 7000d3       ; [m] - initial radius
;  v0 = sqrt(GM/a0)  ; [m/s] - initial circular velocity
;  ;     POSITION  VELOCITY
;  f0 = [a0,0,0,   0,-v0,0] ; initial state vector
;
;  t0 = 100d ; [s] Initial time value, meaningless in this case
;
;  ; Initial output time grid (10000 seconds)
;  tout = dindgen(10000) + t0
;  
;  ; Integrate equations of motion, starting at T0, and proceeding to
;  ; the maximum time of TOUT.  Here the variable GM is passed using
;  ; the PRIVATE mechanism.
;  f = f0 & t = t0
;  ddeabm, 'newton_g', t, f, tout, GM, $
;    tgrid=tgrid, ygrid=ygrid, ypgrid=ypgrid, noutgrid=noutgrid, $
;    status=status, errmsg=errmsg
;
;  Now YGRID(0:2,*)  contains the 3D position of the satellite
;      YGRID(3:5,*)  contains the 3D velocity of the satellite
;      YPGRID(3:5,*) contains the 3D acceleration of the satellite
;
;  An alternate way to call DDEABM is to use its natural gridpoints
;  rather than requesting explicit gridpoints.  In that case, we need
;  to specify the maximum time value we are expecing with TOUT, and
;  a maximum number of output grid values using NGRID.
;
;  f = f0 & t = t0
;  tout = 10000d ;; Maximum requested time
;  ddeabm, 'newton_g', t, f, tout, GM, $
;    ngrid=3000, noutgrid=noutgrid, $
;    tgrid=tgrid, ygrid=ygrid, ypgrid=ypgrid, noutgrid=noutgrid, $
;    status=status, errmsg=errmsg
;
;  NOUTGRID contains the actual number of grid values returned by 
;  DDEABM.  If NOUTGRID is less than NGRID, then the remaining values
;  are to be ignored.
;
;  TGRID = TGRID(0:NOUTGRID-1)
;  YGRID = YGRID(*,0:NOUTGRID-1)
;  YPGRID = YPGRID(*,0:NOUTGRID-1)
;
;  The user can then plot these values are use them as desired.  The
;  result should be a circular orbit at radius 7000000d meters, with
;  constant speed given by V0.
;
;
;  ; WORK FUNCTION ----
;
;  ; The acceleration of Newtonian gravity by a central body
;  ; of mass M.
;  ;   T - time (not used)
;  ;   f - state vector
;  ;     f(0:2) = position vector
;  ;     f(3:5) = velocity vector
;  ;   GM - central body newtonian constant
; FUNCTION NEWTON_G, t, f, GM
;    r = f(0:2) ; Position vector
;    v = f(3:5) ; Velocity vector
;    rsq = total(r^2,1) ;; central body distance, squared
;    rr = sqrt(rsq)     ;; central body distance
;   
;    ;; Newtonian gravitational acceleration, three components
;    a = - GM/rsq * r/rr
;
;    ;; Assemble final differential vector
;    df_dt = [v, a]
;    return, df_dt
; end
;
;
; REFERENCES:
;
;   SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE
;                         Solvers.
;
;   "Solving Ordinary Differential Equations with ODE, STEP, and INTRP",
;       by L. F. Shampine and M. K. Gordon, SLA-73-1060.
;
;    SLATEC Common Mathematical Library, Version 4.1, July 1993
;    a comprehensive software library containing over
;    1400 general purpose mathematical and statistical routines
;    written in Fortran 77.  (http://www.netlib.org/slatec/)
;
;
; MODIFICATION HISTORY:
;    Fix bug in TSTOP keyword, 09 May 2002, CM
;    Fix behavior of KSTEPS, which caused premature termination, 26
;      May 2002, CM
;    Fix two errors in the DDEABM_DINTP interpolation step, 04 Jul 2002, CM
;    Handle case of IMPULSES more correctly, 25 Sep 2002, CM
;    Handle case when INIT is not set (default to 1); detect
;      non-finite user function values and error out with STATUS code
;      -16; promote integer values to LONG integers; some internal 
;      function renaming, 28 Jun 2003, CM
;    Fixed bug in handling of DOIMPULSE and INTERMEDIATE, 08 Mar 2004, CM
;    Corrected interface error in usage of NGRID.  Now NGRID is
;      actually the number of INTERMEDIATE points to compute (and is
;      input only).  NOUTGRID is a new keyword, which provides the
;      number of output grid points upon return.  08 Mar 2004, CM
;    Early termination is possible for INTERMEDIATE case.  Handle it
;      properly , 08 Mar 2004, CM
;    Fix a bug in the handling of INIT (strangely the internal
;      code keeps two different INIT variables!); this really only 
;      had an effect when continuing a previous integration; handle
;      impulses properly when integrating in the negative direction; 
;      document the TIMPULSE/YIMPULSE keyword parameters; some other
;      small code cleanups;  16 Jul 2008, CM
;    Handle the case when TOUT EQ TIMPULSE, 05 Sep 2008, CM
;    Further work on TOUT EQ TIMPULSE, also allowing reporting of
;      function values on either side of a discontinuity, 07 Sep 2008, CM
;    Add the MAX_STEPSIZE keyword, 01 Oct 2008, CM
;    Make sure new impulse checks work when integrating in reverse
;      direction, 09 Oct 2008, CM
;    New interface requirement: user function must be able to handle 
;      control messages from DDEABM; first one is INITIALIZE,
;      20 Oct 2008, CM
;    Change the control message interface so that it is
;      backward-compatible; the user must now set the /CONTROL keyword
;      to enable control messages; they are passed to the user
;      function via the CONTROL keyword, 08 Nov 2008, CM
;   Update the documentation; the largest change is the inclusion of
;      a new example, 16 Jan 2010, CM
;   Update documentation with correct spelling of Bashforth,
;      2012-12-18, CM
;
;  $Id: ddeabm.pro,v 1.33 2012/12/19 01:16:44 cmarkwar Exp $
;-
; Portions Copyright (C) 2002, 2003, 2004, 2008, 2010, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; *DECK DDEABM
; C***BEGIN PROLOGUE  DDEABM
; C***PURPOSE  Solve an initial value problem in ordinary differential
; C            equations using an Adams-Bashforth method.
; C***LIBRARY   SLATEC (DEPAC)
; C***CATEGORY  I1A1B
; C***TYPE      DOUBLE PRECISION (DEABM-S, DDEABM-D)
; C***KEYWORDS  ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS,
; C             ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR
; C***AUTHOR  Shampine, L. F., (SNLA)
; C           Watts, H. A., (SNLA)
; C***DESCRIPTION
; C
; C   This is the Adams code in the package of differential equation
; C   solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF.
; C   Design of the package was by L. F. Shampine and H. A. Watts.
; C   It is documented in
; C        SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE
; C                              Solvers.
; C   DDEABM is a driver for a modification of the code ODE written by
; C             L. F. Shampine and M. K. Gordon
; C             Sandia Laboratories
; C             Albuquerque, New Mexico 87185
;
;   $Id: ddeabm.pro,v 1.33 2012/12/19 01:16:44 cmarkwar Exp $
;
; C
; C **********************************************************************
; C * ABSTRACT *
; C ************
; C
; C   Subroutine DDEABM uses the Adams-Bashforth-Moulton
; C   Predictor-Corrector formulas of orders one through twelve to
; C   integrate a system of NEQ first order ordinary differential
; C   equations of the form
; C                         DU/DX = DF(X,U)
; C   when the vector Y(*) of initial values for U(*) at X=T is given.
; C   The subroutine integrates from T to TOUT. It is easy to continue the
; C   integration to get results at additional TOUT.  This is the interval
; C   mode of operation.  It is also easy for the routine to return with
; C   the solution at each intermediate step on the way to TOUT.  This is
; C   the intermediate-output mode of operation.
; C
; C   DDEABM uses subprograms DDEABM_DDES, DDEABM_DSTEPS, DDEABM_DINTP, DHSTRT, DHVNRM,
; C   D1MACH, and the error handling routine XERMSG.  The only machine
; C   dependent parameters to be assigned appear in D1MACH.
; C
; C **********************************************************************
; C * Description of The Arguments To DDEABM (An Overview) *
; C **********************************************************************
; C
; C   The Parameters are
; C
; C      DF -- This is the name of a subroutine which you provide to
; C             define the differential equations.
; C
; C      NEQ -- This is the number of (first order) differential
; C             equations to be integrated.
; C
; C      T -- This is a DOUBLE PRECISION value of the independent
; C           variable.
; C
; C      Y(*) -- This DOUBLE PRECISION array contains the solution
; C              components at T.
; C
; C      TOUT -- This is a DOUBLE PRECISION point at which a solution is
; C              desired.
; C
; C      INFO(*) -- The basic task of the code is to integrate the
; C             differential equations from T to TOUT and return an
; C             answer at TOUT.  INFO(*) is an INTEGER array which is used
; C             to communicate exactly how you want this task to be
; C             carried out.
; C
; C      RTOL, ATOL -- These DOUBLE PRECISION quantities represent
; C                    relative and absolute error tolerances which you
; C                    provide to indicate how accurately you wish the
; C                    solution to be computed.  You may choose them to be
; C                    both scalars or else both vectors.
; C
; C      IDID -- This scalar quantity is an indicator reporting what
; C             the code did.  You must monitor this INTEGER variable to
; C             decide what action to take next.
; C
; C      RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of
; C             length LRW which provides the code with needed storage
; C             space.
; C
; C      IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW
; C             which provides the code with needed storage space and an
; C             across call flag.
; C
; C      RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter
; C             arrays which you can use for communication between your
; C             calling program and the DF subroutine.
; C
; C  Quantities which are used as input items are
; C             NEQ, T, Y(*), TOUT, INFO(*),
; C             RTOL, ATOL, RWORK(1), LRW and LIW.
; C
; C  Quantities which may be altered by the code are
; C             T, Y(*), INFO(1), RTOL, ATOL,
; C             IDID, RWORK(*) and IWORK(*).
; C
; C **********************************************************************
; C * INPUT -- What To Do On The First Call To DDEABM *
; C **********************************************************************
; C
; C   The first call of the code is defined to be the start of each new
; C   problem.  Read through the descriptions of all the following items,
; C   provide sufficient storage space for designated arrays, set
; C   appropriate variables for the initialization of the problem, and
; C   give information about how you want the problem to be solved.
; C
; C
; C      DF -- Provide a subroutine of the form
; C                               DF(X,U,UPRIME,PAR,IPAR)
; C             to define the system of first order differential equations
; C             which is to be solved.  For the given values of X and the
; C             vector  U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must
; C             evaluate the NEQ components of the system of differential
; C             equations  DU/DX=DF(X,U)  and store the derivatives in the
; C             array UPRIME(*), that is,  UPRIME(I) = * DU(I)/DX *  for
; C             equations I=1,...,NEQ.
; C
; C             Subroutine DF must NOT alter X or U(*).  You must declare
; C             the name df in an external statement in your program that
; C             calls DDEABM.  You must dimension U and UPRIME in DF.
; C
; C             RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter
; C             arrays which you can use for communication between your
; C             calling program and subroutine DF. They are not used or
; C             altered by DDEABM.  If you do not need RPAR or IPAR,
; C             ignore these parameters by treating them as dummy
; C             arguments. If you do choose to use them, dimension them in
; C             your calling program and in DF as arrays of appropriate
; C             length.
; C
; C      NEQ -- Set it to the number of differential equations.
; C             (NEQ .GE. 1)
; C
; C      T -- Set it to the initial point of the integration.
; C             You must use a program variable for T because the code
; C             changes its value.
; C
; C      Y(*) -- Set this vector to the initial values of the NEQ solution
; C             components at the initial point.  You must dimension Y at
; C             least NEQ in your calling program.
; C
; C      TOUT -- Set it to the first point at which a solution
; C             is desired.  You can take TOUT = T, in which case the code
; C             will evaluate the derivative of the solution at T and
; C             return. Integration either forward in T  (TOUT .GT. T)  or
; C             backward in T  (TOUT .LT. T)  is permitted.
; C
; C             The code advances the solution from T to TOUT using
; C             step sizes which are automatically selected so as to
; C             achieve the desired accuracy.  If you wish, the code will
; C             return with the solution and its derivative following
; C             each intermediate step (intermediate-output mode) so that
; C             you can monitor them, but you still must provide TOUT in
; C             accord with the basic aim of the code.
; C
; C             The first step taken by the code is a critical one
; C             because it must reflect how fast the solution changes near
; C             the initial point.  The code automatically selects an
; C             initial step size which is practically always suitable for
; C             the problem. By using the fact that the code will not step
; C             past TOUT in the first step, you could, if necessary,
; C             restrict the length of the initial step size.
; C
; C             For some problems it may not be permissible to integrate
; C             past a point TSTOP because a discontinuity occurs there
; C             or the solution or its derivative is not defined beyond
; C             TSTOP.  When you have declared a TSTOP point (see INFO(4)
; C             and RWORK(1)), you have told the code not to integrate
; C             past TSTOP.  In this case any TOUT beyond TSTOP is invalid
; C             input.
; C
; C      INFO(*) -- Use the INFO array to give the code more details about
; C             how you want your problem solved.  This array should be
; C             dimensioned of length 15 to accommodate other members of
; C             DEPAC or possible future extensions, though DDEABM uses
; C             only the first four entries.  You must respond to all of
; C             the following items which are arranged as questions.  The
; C             simplest use of the code corresponds to answering all
; C             questions as YES ,i.e. setting ALL entries of INFO to 0.
; C
; C        INFO(1) -- This parameter enables the code to initialize
; C               itself.  You must set it to indicate the start of every
; C               new problem.
; C
; C            **** Is this the first call for this problem ...
; C                  YES -- set INFO(1) = 0
; C                   NO -- not applicable here.
; C                         See below for continuation calls.  ****
; C
; C        INFO(2) -- How much accuracy you want of your solution
; C               is specified by the error tolerances RTOL and ATOL.
; C               The simplest use is to take them both to be scalars.
; C               To obtain more flexibility, they can both be vectors.
; C               The code must be told your choice.
; C
; C            **** Are both error tolerances RTOL, ATOL scalars ...
; C                  YES -- set INFO(2) = 0
; C                         and input scalars for both RTOL and ATOL
; C                   NO -- set INFO(2) = 1
; C                         and input arrays for both RTOL and ATOL ****
; C
; C        INFO(3) -- The code integrates from T in the direction
; C               of TOUT by steps.  If you wish, it will return the
; C               computed solution and derivative at the next
; C               intermediate step (the intermediate-output mode) or
; C               TOUT, whichever comes first.  This is a good way to
; C               proceed if you want to see the behavior of the solution.
; C               If you must have solutions at a great many specific
; C               TOUT points, this code will compute them efficiently.
; C
; C            **** Do you want the solution only at
; C                 TOUT (and not at the next intermediate step) ...
; C                  YES -- set INFO(3) = 0
; C                   NO -- set INFO(3) = 1 ****
; C
; C        INFO(4) -- To handle solutions at a great many specific
; C               values TOUT efficiently, this code may integrate past
; C               TOUT and interpolate to obtain the result at TOUT.
; C               Sometimes it is not possible to integrate beyond some
; C               point TSTOP because the equation changes there or it is
; C               not defined past TSTOP.  Then you must tell the code
; C               not to go past.
; C
; C            **** Can the integration be carried out without any
; C                 Restrictions on the independent variable T ...
; C                  YES -- set INFO(4)=0
; C                   NO -- set INFO(4)=1
; C                         and define the stopping point TSTOP by
; C                         setting RWORK(1)=TSTOP ****
; C
; C      RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL)
; C             error tolerances to tell the code how accurately you want
; C             the solution to be computed.  They must be defined as
; C             program variables because the code may change them.  You
; C             have two choices --
; C                  Both RTOL and ATOL are scalars. (INFO(2)=0)
; C                  Both RTOL and ATOL are vectors. (INFO(2)=1)
; C             In either case all components must be non-negative.
; C
; C             The tolerances are used by the code in a local error test
; C             at each step which requires roughly that
; C                     ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL
; C             for each vector component.
; C             (More specifically, a Euclidean norm is used to measure
; C             the size of vectors, and the error test uses the magnitude
; C             of the solution at the beginning of the step.)
; C
; C             The true (global) error is the difference between the true
; C             solution of the initial value problem and the computed
; C             approximation.  Practically all present day codes,
; C             including this one, control the local error at each step
; C             and do not even attempt to control the global error
; C             directly.  Roughly speaking, they produce a solution Y(T)
; C             which satisfies the differential equations with a
; C             residual R(T),    DY(T)/DT = DF(T,Y(T)) + R(T)   ,
; C             and, almost always, R(T) is bounded by the error
; C             tolerances.  Usually, but not always, the true accuracy of
; C             the computed Y is comparable to the error tolerances. This
; C             code will usually, but not always, deliver a more accurate
; C             solution if you reduce the tolerances and integrate again.
; C             By comparing two such solutions you can get a fairly
; C             reliable idea of the true error in the solution at the
; C             bigger tolerances.
; C
; C             Setting ATOL=0.D0 results in a pure relative error test on
; C             that component. Setting RTOL=0. results in a pure absolute
; C             error test on that component.  A mixed test with non-zero
; C             RTOL and ATOL corresponds roughly to a relative error
; C             test when the solution component is much bigger than ATOL
; C             and to an absolute error test when the solution component
; C             is smaller than the threshold ATOL.
; C
; C             Proper selection of the absolute error control parameters
; C             ATOL  requires you to have some idea of the scale of the
; C             solution components.  To acquire this information may mean
; C             that you will have to solve the problem more than once. In
; C             the absence of scale information, you should ask for some
; C             relative accuracy in all the components (by setting  RTOL
; C             values non-zero) and perhaps impose extremely small
; C             absolute error tolerances to protect against the danger of
; C             a solution component becoming zero.
; C
; C             The code will not attempt to compute a solution at an
; C             accuracy unreasonable for the machine being used.  It will
; C             advise you if you ask for too much accuracy and inform
; C             you as to the maximum accuracy it believes possible.
; C
; C      RWORK(*) -- Dimension this DOUBLE PRECISION work array of length
; C             LRW in your calling program.
; C
; C      RWORK(1) -- If you have set INFO(4)=0, you can ignore this
; C             optional input parameter.  Otherwise you must define a
; C             stopping point TSTOP by setting   RWORK(1) = TSTOP.
; C             (for some problems it may not be permissible to integrate
; C             past a point TSTOP because a discontinuity occurs there
; C             or the solution or its derivative is not defined beyond
; C             TSTOP.)
; C
; C      LRW -- Set it to the declared length of the RWORK array.
; C             You must have  LRW .GE. 130+21*NEQ
; C
; C      IWORK(*) -- Dimension this INTEGER work array of length LIW in
; C             your calling program.
; C
; C      LIW -- Set it to the declared length of the IWORK array.
; C             You must have  LIW .GE. 51
; C
; C      RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and
; C             INTEGER type, respectively.  You can use them for
; C             communication between your program that calls DDEABM and
; C             the  DF subroutine.  They are not used or altered by
; C             DDEABM.  If you do not need RPAR or IPAR, ignore these
; C             parameters by treating them as dummy arguments.  If you do
; C             choose to use them, dimension them in your calling program
; C             and in DF as arrays of appropriate length.
; C
; C **********************************************************************
; C * OUTPUT -- After Any Return From DDEABM *
; C **********************************************************************
; C
; C   The principal aim of the code is to return a computed solution at
; C   TOUT, although it is also possible to obtain intermediate results
; C   along the way.  To find out whether the code achieved its goal
; C   or if the integration process was interrupted before the task was
; C   completed, you must check the IDID parameter.
; C
; C
; C      T -- The solution was successfully advanced to the
; C             output value of T.
; C
; C      Y(*) -- Contains the computed solution approximation at T.
; C             You may also be interested in the approximate derivative
; C             of the solution at T.  It is contained in
; C             RWORK(21),...,RWORK(20+NEQ).
; C
; C      IDID -- Reports what the code did
; C
; C                         *** Task Completed ***
; C                   Reported by positive values of IDID
; C
; C             IDID = 1 -- A step was successfully taken in the
; C                       intermediate-output mode.  The code has not
; C                       yet reached TOUT.
; C
; C             IDID = 2 -- The integration to TOUT was successfully
; C                       completed (T=TOUT) by stepping exactly to TOUT.
; C
; C             IDID = 3 -- The integration to TOUT was successfully
; C                       completed (T=TOUT) by stepping past TOUT.
; C                       Y(*) is obtained by interpolation.
; C
; C                         *** Task Interrupted ***
; C                   Reported by negative values of IDID
; C
; C             IDID = -1 -- A large amount of work has been expended.
; C                       (500 steps attempted)
; C
; C             IDID = -2 -- The error tolerances are too stringent.
; C
; C             IDID = -3 -- The local error test cannot be satisfied
; C                       because you specified a zero component in ATOL
; C                       and the corresponding computed solution
; C                       component is zero.  Thus, a pure relative error
; C                       test is impossible for this component.
; C
; C             IDID = -4 -- The problem appears to be stiff.
; C
; C             IDID = -5,-6,-7,..,-32  -- Not applicable for this code
; C                       but used by other members of DEPAC or possible
; C                       future extensions.
; C
; C                         *** Task Terminated ***
; C                   Reported by the value of IDID=-33
; C
; C             IDID = -33 -- The code has encountered trouble from which
; C                       it cannot recover.  A message is printed
; C                       explaining the trouble and control is returned
; C                       to the calling program. For example, this occurs
; C                       when invalid input is detected.
; C
; C      RTOL, ATOL -- These quantities remain unchanged except when
; C             IDID = -2.  In this case, the error tolerances have been
; C             increased by the code to values which are estimated to be
; C             appropriate for continuing the integration.  However, the
; C             reported solution at T was obtained using the input values
; C             of RTOL and ATOL.
; C
; C      RWORK, IWORK -- Contain information which is usually of no
; C             interest to the user but necessary for subsequent calls.
; C             However, you may find use for
; C
; C             RWORK(11)--which contains the step size H to be
; C                        attempted on the next step.
; C
; C             RWORK(12)--if the tolerances have been increased by the
; C                        code (IDID = -2) , they were multiplied by the
; C                        value in RWORK(12).
; C
; C             RWORK(13)--Which contains the current value of the
; C                        independent variable, i.e. the farthest point
; C                        integration has reached. This will be different
; C                        from T only when interpolation has been
; C                        performed (IDID=3).
; C
; C             RWORK(20+I)--Which contains the approximate derivative
; C                        of the solution component Y(I).  In DDEABM, it
; C                        is obtained by calling subroutine DF to
; C                        evaluate the differential equation using T and
; C                        Y(*) when IDID=1 or 2, and by interpolation
; C                        when IDID=3.
; C
; C **********************************************************************
; C * INPUT -- What To Do To Continue The Integration *
; C *             (calls after the first)             *
; C **********************************************************************
; C
; C        This code is organized so that subsequent calls to continue the
; C        integration involve little (if any) additional effort on your
; C        part. You must monitor the IDID parameter in order to determine
; C        what to do next.
; C
; C        Recalling that the principal task of the code is to integrate
; C        from T to TOUT (the interval mode), usually all you will need
; C        to do is specify a new TOUT upon reaching the current TOUT.
; C
; C        Do not alter any quantity not specifically permitted below,
; C        in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or
; C        the differential equation in subroutine DF. Any such alteration
; C        constitutes a new problem and must be treated as such, i.e.
; C        you must start afresh.
; C
; C        You cannot change from vector to scalar error control or vice
; C        versa (INFO(2)) but you can change the size of the entries of
; C        RTOL, ATOL.  Increasing a tolerance makes the equation easier
; C        to integrate.  Decreasing a tolerance will make the equation
; C        harder to integrate and should generally be avoided.
; C
; C        You can switch from the intermediate-output mode to the
; C        interval mode (INFO(3)) or vice versa at any time.
; C
; C        If it has been necessary to prevent the integration from going
; C        past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the
; C        code will not integrate to any TOUT beyond the currently
; C        specified TSTOP.  Once TSTOP has been reached you must change
; C        the value of TSTOP or set INFO(4)=0.  You may change INFO(4)
; C        or TSTOP at any time but you must supply the value of TSTOP in
; C        RWORK(1) whenever you set INFO(4)=1.
; C
; C        The parameter INFO(1) is used by the code to indicate the
; C        beginning of a new problem and to indicate whether integration
; C        is to be continued.  You must input the value  INFO(1) = 0
; C        when starting a new problem.  You must input the value
; C        INFO(1) = 1  if you wish to continue after an interrupted task.
; C        Do not set  INFO(1) = 0  on a continuation call unless you
; C        want the code to restart at the current T.
; C
; C                         *** Following A Completed Task ***
; C         If
; C             IDID = 1, call the code again to continue the integration
; C                     another step in the direction of TOUT.
; C
; C             IDID = 2 or 3, define a new TOUT and call the code again.
; C                     TOUT must be different from T. You cannot change
; C                     the direction of integration without restarting.
; C
; C                         *** Following An Interrupted Task ***
; C                     To show the code that you realize the task was
; C                     interrupted and that you want to continue, you
; C                     must take appropriate action and reset INFO(1) = 1
; C         If
; C             IDID = -1, the code has attempted 500 steps.
; C                     If you want to continue, set INFO(1) = 1 and
; C                     call the code again. An additional 500 steps
; C                     will be allowed.
; C
; C             IDID = -2, the error tolerances RTOL, ATOL have been
; C                     increased to values the code estimates appropriate
; C                     for continuing.  You may want to change them
; C                     yourself.  If you are sure you want to continue
; C                     with relaxed error tolerances, set INFO(1)=1 and
; C                     call the code again.
; C
; C             IDID = -3, a solution component is zero and you set the
; C                     corresponding component of ATOL to zero.  If you
; C                     are sure you want to continue, you must first
; C                     alter the error criterion to use positive values
; C                     for those components of ATOL corresponding to zero
; C                     solution components, then set INFO(1)=1 and call
; C                     the code again.
; C
; C             IDID = -4, the problem appears to be stiff.  It is very
; C                     inefficient to solve such problems with DDEABM.
; C                     The code DDEBDF in DEPAC handles this task
; C                     efficiently.  If you are absolutely sure you want
; C                     to continue with DDEABM, set INFO(1)=1 and call
; C                     the code again.
; C
; C             IDID = -5,-6,-7,..,-32  --- cannot occur with this code
; C                     but used by other members of DEPAC or possible
; C                     future extensions.
; C
; C                         *** Following A Terminated Task ***
; C         If
; C             IDID = -33, you cannot continue the solution of this
; C                     problem.  An attempt to do so will result in your
; C                     run being terminated.
; C
; C **********************************************************************
; C *Long Description:
; C
; C **********************************************************************
; C *             DEPAC Package Overview           *
; C **********************************************************************
; C
; C ....   You have a choice of three differential equation solvers from
; C ....   DEPAC. The following brief descriptions are meant to aid you in
; C ....   choosing the most appropriate code for your problem.
; C
; C ....   DDERKF is a fifth order Runge-Kutta code. It is the simplest of
; C ....   the three choices, both algorithmically and in the use of the
; C ....   code. DDERKF is primarily designed to solve non-stiff and
; C ....   mildly stiff differential equations when derivative evaluations
; C ....   are not expensive. It should generally not be used to get high
; C ....   accuracy results nor answers at a great many specific points.
; C ....   Because DDERKF has very low overhead costs, it will usually
; C ....   result in the least expensive integration when solving
; C ....   problems requiring a modest amount of accuracy and having
; C ....   equations that are not costly to evaluate. DDERKF attempts to
; C ....   discover when it is not suitable for the task posed.
; C
; C ....   DDEABM is a variable order (one through twelve) Adams code.
; C ....   Its complexity lies somewhere between that of DDERKF and
; C ....   DDEBDF.  DDEABM is primarily designed to solve non-stiff and
; C ....   mildly stiff differential equations when derivative evaluations
; C ....   are expensive, high accuracy results are needed or answers at
; C ....   many specific points are required. DDEABM attempts to discover
; C ....   when it is not suitable for the task posed.
; C
; C ....   DDEBDF is a variable order (one through five) backward
; C ....   differentiation formula code. it is the most complicated of
; C ....   the three choices. DDEBDF is primarily designed to solve stiff
; C ....   differential equations at crude to moderate tolerances.
; C ....   If the problem is very stiff at all, DDERKF and DDEABM will be
; C ....   quite inefficient compared to DDEBDF. However, DDEBDF will be
; C ....   inefficient compared to DDERKF and DDEABM on non-stiff problems
; C ....   because it uses much more storage, has a much larger overhead,
; C ....   and the low order formulas will not give high accuracies
; C ....   efficiently.
; C
; C ....   The concept of stiffness cannot be described in a few words.
; C ....   If you do not know the problem to be stiff, try either DDERKF
; C ....   or DDEABM. Both of these codes will inform you of stiffness
; C ....   when the cost of solving such problems becomes important.
; C
; C *********************************************************************
; C
; C***REFERENCES  L. F. Shampine and H. A. Watts, DEPAC - design of a user
; C                 oriented package of ODE solvers, Report SAND79-2374,
; C                 Sandia Laboratories, 1979.
; C***ROUTINES CALLED  DDEABM_DDES, XERMSG
; C***REVISION HISTORY  (YYMMDD)
; C   820301  DATE WRITTEN
; C   890531  Changed all specific intrinsics to generic.  (WRB)
; C   890831  Modified array declarations.  (WRB)
; C   891006  Cosmetic changes to prologue.  (WRB)
; C   891024  Changed references from DVNORM to DHVNRM.  (WRB)
; C   891024  REVISION DATE from Version 3.2
; C   891214  Prologue converted to Version 4.0 format.  (BAB)
; C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
; C   920501  Reformatted the REFERENCES section.  (WRB)
; C***END PROLOGUE  DDEABM
; C
;       INTEGER IALPHA, IBETA, IDELSN, IDID, IFOURU, IG, IHOLD,
;      1      INFO, IP, IPAR, IPHI, IPSI, ISIG, ITOLD, ITSTAR, ITWOU,
;      2      IV, IW, IWORK, IWT, IYP, IYPOUT, IYY, LIW, LRW, NEQ
;       DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y
;       LOGICAL START,PHASE1,NORND,STIFF,INTOUT
; C
;       DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*),
;      1          RPAR(*),IPAR(*)
; C
;       CHARACTER*8 XERN1
;       CHARACTER*16 XERN3
; C
;       EXTERNAL DF
; C
; C     CHECK FOR AN APPARENT INFINITE LOOP
; C

;; -----------  SOI start of IDL code ----------

pro ddeabm_dummy
  common ddeabm_func_common, ddeabm_nfev, ddeabm_funcerror
end

function ddeabm_func0n, func, a, y, private, _extra=fa
  common ddeabm_func_common, nfev, error
  nfev = nfev + 1
  dydx = call_function(func, a, y)
  if min(finite(dydx)) EQ 0 then error = -16
  return, dydx
end

function ddeabm_func1n, func, a, y, private, _extra=fa
  common ddeabm_func_common, nfev, error
  nfev = nfev + 1
  dydx = call_function(func, a, y, private)
  if min(finite(dydx)) EQ 0 then error = -16
  return, dydx
end

function ddeabm_func0e, func, a, y, private, _extra=fa
  common ddeabm_func_common, nfev, error
  nfev = nfev + 1
  dydx = call_function(func, a, y, _extra=fa)
  if min(finite(dydx)) EQ 0 then error = -16
  return, dydx
end

function ddeabm_func1e, func, a, y, private, _extra=fa
  common ddeabm_func_common, nfev, error
  nfev = nfev + 1
  dydx = call_function(func, a, y, private, _extra=fa)
  if min(finite(dydx)) EQ 0 then error = -16
  return, dydx
end

; *DECK DDEABM_DHSTRT
pro ddeabm_dhstrt, DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, $
          BIG, SPY, PV, YP, SF, PRIVATE, FA, H, DFNAME
; C***BEGIN PROLOGUE  DDEABM_DHSTRT
; C***SUBSIDIARY
; C***PURPOSE  Subsidiary to DDEABM, DDEBDF and DDERKF
; C***LIBRARY   SLATEC
; C***TYPE      DOUBLE PRECISION (HSTART-S, DHSTRT-D)
; C***AUTHOR  Watts, H. A., (SNLA)
; C***DESCRIPTION
; C
; C   DDEABM_DHSTRT computes a starting step size to be used in solving initial
; C   value problems in ordinary differential equations.
; C
; C **********************************************************************
; C  ABSTRACT
; C
; C     Subroutine DDEABM_DHSTRT computes a starting step size to be used by an
; C     initial value method in solving ordinary differential equations.
; C     It is based on an estimate of the local Lipschitz constant for the
; C     differential equation   (lower bound on a norm of the Jacobian) ,
; C     a bound on the differential equation  (first derivative) , and
; C     a bound on the partial derivative of the equation with respect to
; C     the independent variable.
; C     (all approximated near the initial point A)
; C
; C     Subroutine DDEABM_DHSTRT uses a function subprogram DHVNRM for computing
; C     a vector norm. The maximum norm is presently utilized though it
; C     can easily be replaced by any other vector norm. It is presumed
; C     that any replacement norm routine would be carefully coded to
; C     prevent unnecessary underflows or overflows from occurring, and
; C     also, would not alter the vector or number of components.
; C
; C **********************************************************************
; C  On input you must provide the following
; C
; C      DF -- This is a subroutine of the form
; C                               DF(X,U,UPRIME,RPAR,IPAR)
; C             which defines the system of first order differential
; C             equations to be solved. For the given values of X and the
; C             vector  U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must
; C             evaluate the NEQ components of the system of differential
; C             equations  DU/DX=DF(X,U)  and store the derivatives in the
; C             array UPRIME(*), that is,  UPRIME(I) = * DU(I)/DX *  for
; C             equations I=1,...,NEQ.
; C
; C             Subroutine DF must not alter X or U(*). You must declare
; C             the name DF in an external statement in your program that
; C             calls DDEABM_DHSTRT. You must dimension U and UPRIME in DF.
; C
; C             RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter
; C             arrays which you can use for communication between your
; C             program and subroutine DF. They are not used or altered by
; C             DDEABM_DHSTRT. If you do not need RPAR or IPAR, ignore these
; C             parameters by treating them as dummy arguments. If you do
; C             choose to use them, dimension them in your program and in
; C             DF as arrays of appropriate length.
; C
; C      NEQ -- This is the number of (first order) differential equations
; C             to be integrated.
; C
; C      A -- This is the initial point of integration.
; C
; C      B -- This is a value of the independent variable used to define
; C             the direction of integration. A reasonable choice is to
; C             set  B  to the first point at which a solution is desired.
; C             You can also use  B, if necessary, to restrict the length
; C             of the first integration step because the algorithm will
; C             not compute a starting step length which is bigger than
; C             ABS(B-A), unless  B  has been chosen too close to  A.
; C             (it is presumed that DDEABM_DHSTRT has been called with  B
; C             different from  A  on the machine being used. Also see the
; C             discussion about the parameter  SMALL.)
; C
; C      Y(*) -- This is the vector of initial values of the NEQ solution
; C             components at the initial point  A.
; C
; C      YPRIME(*) -- This is the vector of derivatives of the NEQ
; C             solution components at the initial point  A.
; C             (defined by the differential equations in subroutine DF)
; C
; C      ETOL -- This is the vector of error tolerances corresponding to
; C             the NEQ solution components. It is assumed that all
; C             elements are positive. Following the first integration
; C             step, the tolerances are expected to be used by the
; C             integrator in an error test which roughly requires that
; C                        ABS(LOCAL ERROR)  .LE.  ETOL
; C             for each vector component.
; C
; C      MORDER -- This is the order of the formula which will be used by
; C             the initial value method for taking the first integration
; C             step.
; C
; C      SMALL -- This is a small positive machine dependent constant
; C             which is used for protecting against computations with
; C             numbers which are too small relative to the precision of
; C             floating point arithmetic.  SMALL  should be set to
; C             (approximately) the smallest positive DOUBLE PRECISION
; C             number such that  (1.+SMALL) .GT. 1.  on the machine being
; C             used. The quantity  SMALL**(3/8)  is used in computing
; C             increments of variables for approximating derivatives by
; C             differences.  Also the algorithm will not compute a
; C             starting step length which is smaller than
; C             100*SMALL*ABS(A).
; C
; C      BIG -- This is a large positive machine dependent constant which
; C             is used for preventing machine overflows. A reasonable
; C             choice is to set big to (approximately) the square root of
; C             the largest DOUBLE PRECISION number which can be held in
; C             the machine.
; C
; C      SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work
; C             arrays of length NEQ which provide the routine with needed
; C             storage space.
; C
; C      RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and
; C             INTEGER type, respectively, which can be used for
; C             communication between your program and the DF subroutine.
; C             They are not used or altered by DDEABM_DHSTRT.
; C
; C **********************************************************************
; C  On Output  (after the return from DDEABM_DHSTRT),
; C
; C      H -- is an appropriate starting step size to be attempted by the
; C             differential equation method.
; C
; C           All parameters in the call list remain unchanged except for
; C           the working arrays SPY(*),PV(*),YP(*), and SF(*).
; C
; C **********************************************************************
; C
; C***SEE ALSO  DDEABM, DDEBDF, DDERKF
; C***ROUTINES CALLED  DHVNRM
; C***REVISION HISTORY  (YYMMDD)
; C   820301  DATE WRITTEN
; C   890531  Changed all specific intrinsics to generic.  (WRB)
; C   890831  Modified array declarations.  (WRB)
; C   890911  Removed unnecessary intrinsics.  (WRB)
; C   891024  Changed references from DVNORM to DHVNRM.  (WRB)
; C   891214  Prologue converted to Version 4.0 format.  (BAB)
; C   900328  Added TYPE section.  (WRB)
; C   910722  Updated AUTHOR section.  (ALS)
; C***END PROLOGUE  DDEABM_DHSTRT
; C
;       INTEGER IPAR, J, K, LK, MORDER, NEQ
;       DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY,
;      1      DFDUB, DFDXB, DHVNRM,
;      2      DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY,
;      3      SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME
;       DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*),
;      1          SF(*),RPAR(*),IPAR(*)
;       EXTERNAL DF
; C
; C     ..................................................................
; C
; C     BEGIN BLOCK PERMITTING ...EXITS TO 160
; C***FIRST EXECUTABLE STATEMENT  DDEABM_DHSTRT
         common ddeabm_func_common
         DX = B - A
         ABSDX = ABS(DX)
         RELPER = SMALL^0.375D0
; C
; C        ...............................................................
; C
; C             COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL
; C             DERIVATIVE OF THE EQUATION WITH RESPECT TO THE
; C             INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW.
; C             ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE
; C             LOCALLY.
; C
         DA = MAX([MIN([RELPER*ABS(A),ABSDX]), 100.0D0*SMALL*ABS(A)])
         DA = (DX GE 0)?(+DA):(-DA)
         IF (DA EQ 0.0D0) THEN DA = RELPER*DX

         SF = CALL_FUNCTION(DFNAME, DF, A+DA, Y, PRIVATE, _EXTRA=FA)
         if ddeabm_funcerror NE 0 then return

         YP = SF - YPRIME
         DELF = max(abs(YP))
         DFDXB = BIG
         IF (DELF LT BIG*ABS(DA)) THEN DFDXB = DELF/ABS(DA)
         FBND = max(abs(SF))
; C
; C        ...............................................................
; C
; C             COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ
; C             CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS
; C             ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN
; C             LOCALLY.  THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO
; C             ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES.
; C             THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL
; C             DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND
; C             PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF
; C             THE DIFFERENTIAL EQUATION.  THE THIRD PERTURBATION VECTOR
; C             IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL
; C             VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO
; C             NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN
; C             INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT
; C             COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE
; C             CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES.
; C             ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST
; C             DERIVATIVE.
; C
; C                               PERTURBATION VECTOR SIZE IS HELD
; C                               CONSTANT FOR ALL ITERATIONS. COMPUTE
; C                               THIS CHANGE FROM THE
; C                                       SIZE OF THE VECTOR OF INITIAL
; C                                       VALUES.
         DELY = RELPER*max(abs(y))
         IF (DELY EQ 0.0D0) THEN DELY = RELPER
         DELY = (DX GE 0)?(+DELY):(-DELY)
         DELF = max(abs(YPRIME))
         FBND = MAX([FBND,DELF])
         IF (DELF NE 0.0D0) THEN BEGIN
; C           USE INITIAL DERIVATIVES FOR FIRST PERTURBATION
             SPY = YPRIME
             YP = YPRIME
         ENDIF ELSE BEGIN
; C           CANNOT HAVE A NULL PERTURBATION VECTOR
             SPY(*) = 0
             YP(*) = 1
             DELF = max(abs(yp))
         ENDELSE
; C
         DFDUB = 0.0D0
         LK = MIN([NEQ+1,3])
         FOR K = 1L, LK DO BEGIN

; C           DEFINE PERTURBED VECTOR OF INITIAL VALUES
             PV = Y + DELY*(YP/DELF)
             IF (K NE 2) THEN BEGIN
; C              EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED
; C              VECTOR  AND  COMPUTE CORRESPONDING DIFFERENCES

                 YP = CALL_FUNCTION(DFNAME, DF, A, PV, PRIVATE, _EXTRA=FA)
                 if ddeabm_funcerror NE 0 then return
                 PV = YP - YPRIME
            ENDIF ELSE BEGIN
; C              USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE
; C                                    IN COMPUTING ONE ESTIMATE

                YP = CALL_FUNCTION(DFNAME, DF, A+DA, PV, PRIVATE, _EXTRA=FA)
                if ddeabm_funcerror NE 0 then return
                PV = YP - SF
            ENDELSE
; C           CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE
; C                          AND A LOCAL LIPSCHITZ CONSTANT
            FBND = MAX([FBND,max(abs(yp))])
            DELF = max(abs(pv))
; C        ...EXIT
            IF (DELF GE BIG*ABS(DELY)) THEN GOTO, DHSTRT_150
            DFDUB = MAX([DFDUB,DELF/ABS(DELY)])
; C     ......EXIT
            IF (K EQ LK) THEN GOTO, DHSTRT_160
; C           CHOOSE NEXT PERTURBATION VECTOR
            IF (DELF EQ 0.0D0) THEN DELF = 1.0D0
            IF (K NE 2) THEN BEGIN
                DY = ABS(PV)
                wh = where(dy EQ 0, ct)
                if ct GT 0 then dy(wh) = DELF
            endif else begin
                DY = Y
                wh = where(dy EQ 0, ct)
                if ct GT 0 then dy(wh) = DELY/RELPER
            endelse
            wh = where(spy EQ 0, ct)
            if ct GT 0 then spy(wh) = yp(wh)
            wh = where(spy LT 0, ct)
            if ct GT 0 then dy(wh) = -dy(wh)
            yp(*) = dy
            DELF = max(abs(YP))
        ENDFOR
        DHSTRT_150:
; C
; C        PROTECT AGAINST AN OVERFLOW
        DFDUB = BIG
        DHSTRT_160:
; C
; C     ..................................................................
; C
; C          COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE
; C
      YDPB = DFDXB + DFDUB*FBND
; C
; C     ..................................................................
; C
; C          DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP
; C          SIZE IS TO BE BASED.  A VALUE IN THE MIDDLE OF THE ERROR
; C          TOLERANCE RANGE IS SELECTED.
; C
      TOLEXP = ALOG10(ETOL)
      TOLMIN = MIN(TOLEXP)
      TOLSUM = TOTAL(TOLEXP)
      TOLP = 10.0D0^(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1))
; C
; C     ..................................................................
; C
; C          COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND
; C          SECOND DERIVATIVE INFORMATION
; C
; C                            RESTRICT THE STEP LENGTH TO BE NOT BIGGER
; C                            THAN ABS(B-A).   (UNLESS  B  IS TOO CLOSE
; C                            TO  A)
      H = ABSDX
; C
      IF (YDPB EQ 0.0D0 AND FBND EQ 0.0D0) THEN BEGIN
; GO TO 180
; C
; C        BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND
; C                     DERIVATIVE TERM (YDPB) ARE ZERO
         IF (TOLP LT 1.0D0) THEN H = ABSDX*TOLP
     ENDIF ELSE IF (YDPB EQ 0.0D0) THEN BEGIN
; C        ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO
         IF (TOLP LT FBND*ABSDX) THEN H = TOLP/FBND
     ENDIF ELSE BEGIN
; C        SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO
         SRYDPB = SQRT(0.5D0*YDPB)
         IF (TOLP LT SRYDPB*ABSDX) THEN H = TOLP/SRYDPB
     ENDELSE

; C     FURTHER RESTRICT THE STEP LENGTH TO BE NOT
; C                               BIGGER THAN  1/DFDUB
      IF (H*DFDUB GT 1.0D0) THEN H = 1.0D0/DFDUB

; C     FINALLY, RESTRICT THE STEP LENGTH TO BE NOT
; C     SMALLER THAN  100*SMALL*ABS(A).  HOWEVER, IF
; C     A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO,
; C     THE ALGORITHM RETURNS  SMALL*ABS(B)  FOR THE
; C                                     STEP LENGTH.
      H = MAX([H,100.0D0*SMALL*ABS(A)])
      IF (H EQ 0.0D0) THEN H = SMALL*ABS(B)

; C     NOW SET DIRECTION OF INTEGRATION
      H = (DX GE 0)?(+H):(-H)

      RETURN
  END





; *DECK DDEABM_DDES

      pro ddeabm_ddes, DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, $
        YPOUT, YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, $
        H, EPS, X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, $
        PHASE1, NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, $
        KLE4, IQUIT, KPREV, IVC, IV, KGI, PRIVATE, FA, dfname, $
                errmsg=errmsg, max_stepsize=max_stepsize
; C***BEGIN PROLOGUE  DDEABM_DDES
; C***SUBSIDIARY
; C***PURPOSE  Subsidiary to DDEABM
; C***LIBRARY   SLATEC
; C***TYPE      DOUBLE PRECISION (DES-S, DDES-D)
; C***AUTHOR  Watts, H. A., (SNLA)
; C***DESCRIPTION
; C
; C   DDEABM merely allocates storage for DDEABM_DDES to relieve the user of the
; C   inconvenience of a long call list.  Consequently  DDEABM_DDES  is used as
; C   described in the comments for  DDEABM .
; C
; C***SEE ALSO  DDEABM
; C***ROUTINES CALLED  D1MACH, DDEABM_DINTP, DDEABM_DSTEPS, XERMSG
; C***REVISION HISTORY  (YYMMDD)
; C   820301  DATE WRITTEN
; C   890531  Changed all specific intrinsics to generic.  (WRB)
; C   890831  Modified array declarations.  (WRB)
; C   891214  Prologue converted to Version 4.0 format.  (BAB)
; C   900328  Added TYPE section.  (WRB)
; C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTOs to
; C           IF-THEN-ELSE.  (RWC)
; C   910722  Updated AUTHOR section.  (ALS)
; C***END PROLOGUE  DDEABM_DDES
; C
;       INTEGER IDID, INFO, INIT, IPAR, IQUIT, IV, IVC, K, KGI, KLE4,
;      1      KOLD, KORD, KPREV, KSTEPS, L, LTOL, MAXNUM, NATOLP, NEQ,
;      2      NRTOLP, NS
;       DOUBLE PRECISION A, ABSDEL, ALPHA, ATOL, BETA, D1MACH,
;      1      DEL, DELSGN, DT, EPS, FOURU, G, GI, H,
;      2      HA, HOLD, P, PHI, PSI, RPAR, RTOL, SIG, T, TOLD, TOUT,
;      3      TSTOP, TWOU, U, V, W, WT, X, XOLD, Y, YP, YPOUT, YY
;       LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT
; C
;      DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*),
;     1  YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),
;     2  GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*)
;      CHARACTER*8 XERN1
;      CHARACTER*16 XERN3, XERN4
; C
;       EXTERNAL DF
; C
; C.......................................................................
; C
; C  THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE
; C  NUMBER OF  STEPS ATTEMPTED. WHEN THIS EXCEEDS  MAXNUM, THE COUNTER
; C  IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE
; C  WORK.
; C
      MAXNUM = 500L
; C
; C.......................................................................
; C
; C***FIRST EXECUTABLE STATEMENT  DDEABM_DDES
      common ddeabm_func_common
      IF (INFO(1-1) EQ 0) THEN BEGIN
; C
; C ON THE FIRST CALL , PERFORM INITIALIZATION --
; C        DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY  U  BY CALLING THE
; C        FUNCTION ROUTINE  D1MACH. THE USER MUST MAKE SURE THAT THE
; C        VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED.
; C
         U=(machar(/double)).eps  ;; XXX
; C                       -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS
         TWOU=2.D0*U
         FOURU=4.D0*U
; C                       -- SET TERMINATION FLAG
         IQUIT=0L
; C                       -- SET INITIALIZATION INDICATOR
         INIT=0L
; C                       -- SET COUNTER FOR ATTEMPTED STEPS
         KSTEPS=0L
; C                       -- SET INDICATOR FOR INTERMEDIATE-OUTPUT
         INTOUT= 0L
; C                       -- SET INDICATOR FOR STIFFNESS DETECTION
         STIFF= 0L
; C                       -- SET STEP COUNTER FOR STIFFNESS DETECTION
         KLE4=0L
; C                       -- SET INDICATORS FOR STEPS CODE
         START= 1L
         PHASE1= 1L
         NORND= 1L
; C                       -- RESET INFO(1) FOR SUBSEQUENT CALLS
         INFO(1-1)=1L
      ENDIF
; C
; C.......................................................................
; C
; C      CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY
; C
      IF (INFO(1-1) NE 0  AND  INFO(1-1) NE 1) THEN BEGIN
          errmsg = 'IN DDEABM, INFO(1-1) MUST BE '+ $
            'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE '+ $
            'SET TO 1 FOLLOWING AN INTERRUPTED TASK.  YOU ARE '+ $
            'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY '+ $
            'CALLING THE CODE WITH INFO(1-1) = ' + strtrim(info(1-1),2)
          IDID=-33L
      ENDIF

      IF (INFO(2-1) NE 0  AND  INFO(2-1) NE 1) THEN BEGIN
          errmsg = 'IN DDEABM, INFO(2-1) MUST BE '+ $
            '0 OR 1 INDICATING SCALAR AND VECTOR ERROR TOLERANCES, '+ $
            'RESPECTIVELY.  YOU HAVE CALLED THE CODE WITH INFO(2-1) = '+ $
            strtrim(info(2-1),2)
         IDID=-33L
      ENDIF

      IF (INFO(3-1) NE 0  AND  INFO(3-1) NE 1) THEN BEGIN
          errmsg = 'IN DDEABM, INFO(3-1) MUST BE '+ $
            '0 OR 1 INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT '+ $
            'MODE OF INTEGRATION, RESPECTIVELY.  YOU HAVE CALLED '+ $
            'THE CODE WITH  INFO(3-1) = '+strtrim(info(3-1),2)
         IDID=-33L
      ENDIF

      IF (INFO(4-1) NE 0  AND  INFO(4-1) NE 1) THEN BEGIN
         errmsg = 'IN DDEABM, INFO(4-1) MUST BE '+ $
           '0 OR 1 INDICATING WHETHER OR NOT THE INTEGRATION '+ $
           'INTERVAL IS TO BE RESTRICTED BY A POINT TSTOP.  YOU '+ $
           'HAVE CALLED THE CODE WITH INFO(4-1) = '+strtrim(info(4-1),2)
         IDID=-33L
      ENDIF

      IF (NEQ LT 1) THEN BEGIN
         errmsg = 'IN DDEABM,  THE NUMBER OF '+ $
           'EQUATIONS NEQ MUST BE A POSITIVE INTEGER.  YOU HAVE '+ $
           'CALLED THE CODE WITH  NEQ = '+strtrim(neq,2)
         IDID=-33L
      ENDIF

      whr = where(rtol LT 0, nrtolp)
      wha = where(atol LT 0, natolp)

      NRTOLP = total( (RTOL LT 0) ) NE 0
      NATOLP = total( (ATOL LT 0) ) NE 0

      if nrtolp NE 0 then begin
          errmsg = 'IN DDEABM, THE RELATIVE '+ $
            'ERROR TOLERANCES RTOL MUST BE NON-NEGATIVE.  YOU '+ $
            'HAVE CALLED THE CODE WITH  RTOL('+strtrim(whr(0),2)+') = '+ $
            strtrim(rtol(whr(0)),2)+ $
            '. IN THE CASE OF VECTOR ERROR TOLERANCES, '+$
            'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.'
          IDID = -33L
      endif else if natolp NE 0 then begin
          errmsg = 'IN DDEABM, THE ABSOLUTE '+ $
            'ERROR TOLERANCES ATOL MUST BE NON-NEGATIVE.  YOU '+ $
            'HAVE CALLED THE CODE WITH  ATOL('+strtrim(wha(0),2)+'-1) = '+ $
            strtrim(atol(wha(0)),2)+ $
            '.  IN THE CASE OF VECTOR ERROR TOLERANCES, '+ $
            'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.'
          IDID = -33L
      ENDIF

     DDES_100:
     IF (INFO(4-1) EQ 1) THEN BEGIN
         IF ( (TOUT-T)*(TSTOP-T) LT 0 $
              OR ABS(TOUT-T) GT ABS(TSTOP-T)) THEN BEGIN
            errmsg = 'IN DDEABM, YOU HAVE '+ $
              'CALLED THE CODE WITH  TOUT = '+strtrim(tout,2)+' BUT '+ $
              'YOU HAVE ALSO TOLD THE CODE (INFO(4-1) = 1) NOT TO '+ $
              'INTEGRATE PAST THE POINT TSTOP = '+strtrim(tstop,2)+ $
              ' THESE INSTRUCTIONS CONFLICT.'
            IDID=-33L
         ENDIF
      ENDIF
; C
; C     CHECK SOME CONTINUATION POSSIBILITIES
; C
      IF (INIT NE 0) THEN BEGIN
         IF (T EQ TOUT) THEN BEGIN
            errmsg = 'IN DDEABM, YOU HAVE '+ $
              'CALLED THE CODE WITH  T = TOUT = '+strtrim(T,2)+ $
              '.  THIS IS NOT ALLOWED ON CONTINUATION CALLS.'
            IDID=-33L
         ENDIF

         IF (T NE TOLD) THEN BEGIN
            errmsg = 'IN DDEABM, YOU HAVE '+ $
              'CHANGED THE VALUE OF T FROM '+strtrim(told,2)+' TO '+ $
              strtrim(t,2)+'  THIS IS NOT ALLOWED ON CONTINUATION CALLS.'
            IDID=-33L
         ENDIF

         IF (INIT NE 1) THEN BEGIN
            IF (DELSGN*(TOUT-T) LT 0.D0) THEN BEGIN
               errmsg = 'IN DDEABM, BY '+ $
                 'CALLING THE CODE WITH TOUT = '+strtrim(tout,2)+ $
                 ' YOU ARE ATTEMPTING TO CHANGE THE DIRECTION OF '+ $
                 'INTEGRATION.  THIS IS NOT ALLOWED WITHOUT '+ $
                 'RESTARTING.'
               IDID=-33L
            ENDIF
         ENDIF
      ENDIF
; C
; C     INVALID INPUT DETECTED
; C
      IF (IDID EQ (-33)) THEN BEGIN
         IF (IQUIT NE (-33)) THEN BEGIN
            IQUIT = -33L
            INFO(1-1) = -1L
         ENDIF ELSE BEGIN
             errmsg = 'IN DDEABM, INVALID '+ $
               'INPUT WAS DETECTED ON SUCCESSIVE ENTRIES.  IT IS '+ $
               'IMPOSSIBLE TO PROCEED BECAUSE YOU HAVE NOT '+ $
               'CORRECTED THE PROBLEM, SO EXECUTION IS BEING '+ $
               'TERMINATED.'
         ENDELSE
         RETURN
      ENDIF
; C
; C.......................................................................
; C
; C     RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS
; C     ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE,
; C     THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE
; C     FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE
; C
      wh = where(rtol+atol EQ 0, ct)
      if ct GT 0 then begin
          ;; Expand RTOL if necessary to be per-vector
          if n_elements(rtol) LT n_elements(atol) then $
            rtol = rtol + atol*0
          rtol(wh) = fouru
          IDID = -2L
      endif

      DDES_190:
      IF (IDID EQ (-2)) THEN BEGIN
; C                       RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A
; C                                                SMALL POSITIVE VALUE
          INFO(1-1)=-1
          RETURN
      ENDIF
; C
; C     BRANCH ON STATUS OF INITIALIZATION INDICATOR
; C            INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE
; C                   AND DIRECTION NOT YET SET
; C            INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET
; C            INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED
; C
      IF (INIT EQ 0) THEN GOTO, DDES_210
      IF (INIT EQ 1) THEN GOTO, DDES_220
      GOTO, DDES_240
; C
; C.......................................................................
; C
; C     MORE INITIALIZATION --
; C                         -- EVALUATE INITIAL DERIVATIVES
; C
      DDES_210:
      INIT=1L
      A=T
      YP = CALL_FUNCTION(DFNAME, DF, A, Y, PRIVATE, _EXTRA=FA)
      if ddeabm_funcerror NE 0 then return
      

      IF (T EQ TOUT) THEN BEGIN
          IDID=2L
          YPOUT = YP
          TOLD=T
          RETURN
      ENDIF
; C
; C                         -- SET INDEPENDENT AND DEPENDENT VARIABLES
; C                                              X AND YY(*) FOR STEPS
; C                         -- SET SIGN OF INTEGRATION DIRECTION
; C                         -- INITIALIZE THE STEP SIZE
; C
      DDES_220:
      INIT = 2L
      X = T
      YY = Y
      DELSGN = (TOUT GE T)?(+1):(-1)
      DELSGNX = (TOUT GE X)?(+1):(-1)
      H = MAX([FOURU*ABS(X),ABS(TOUT-X)])
      if n_elements(max_stepsize) GT 0 then h = h < max_stepsize(0)
      H = H * DELSGNX
; C
; C.......................................................................
; C
; C   ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL
; C   OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT
; C
      DDES_240:
      DEL = TOUT - T
      ABSDEL = ABS(DEL)
; C
; C.......................................................................
; C
; C   IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN
; C
      DDES_250:
      IF (ABS(X-T) GE ABSDEL) THEN BEGIN
          DDEABM_DINTP, X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, $
                                             ALPHA,G,W,XOLD,P
          IDID = 3L
          IF (X EQ TOUT) THEN BEGIN
              IDID = 2L
              INTOUT = 0L
          ENDIF
          T = TOUT
          TOLD = T
          RETURN
      ENDIF
; C
; C   IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE,
; C   EXTRAPOLATE AND RETURN
; C
      IF ((INFO(4-1) EQ 1) AND $
          (ABS(TSTOP-X) LT FOURU*ABS(X))) THEN BEGIN
          DT = TOUT - X
          Y = YY + DT*YP

          YPOUT = CALL_FUNCTION(DFNAME, DF, TOUT, Y, PRIVATE, _EXTRA=FA)
          if ddeabm_funcerror NE 0 then return
          IDID = 3L
          T = TOUT
          TOLD = T
          RETURN
      ENDIF

      IF (INFO(3-1) EQ 0  OR  INTOUT EQ 0) EQ 0 THEN BEGIN
; C
; C   INTERMEDIATE-OUTPUT MODE
; C
          IDID = 1L
          Y = YY
          YPOUT = YP
          T = X
          TOLD = T
          INTOUT = 0L
          RETURN
      ENDIF
; C
; C.......................................................................
; C
; C     MONITOR NUMBER OF STEPS ATTEMPTED
; C
      IF (KSTEPS GT MAXNUM) THEN BEGIN
; C
; C                       A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED
          IDID=-1L
          KSTEPS=0L
          IF (STIFF) THEN BEGIN
; C
; C                       PROBLEM APPEARS TO BE STIFF
              IDID=-4L
              STIFF= 0L
              KLE4=0L
          ENDIF

          Y = YY
          YPOUT = YP
          T = X
          TOLD = T
          INFO(1-1) = -1
          INTOUT = 0L
          RETURN
      ENDIF
; C
; C.......................................................................
; C
; C   LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP
; C
      HA = ABS(H)
      IF (INFO(4-1) EQ 1) THEN BEGIN
          HA = MIN([HA,ABS(TSTOP-X)])
      ENDIF
      H = (H GE 0)?(HA):(-HA)
      EPS = 1.0D0
      LTOL = 1L

      wt = rtol*abs(yy) + atol
      wh = where(wt LE 0, ct)

; C
; C                       RELATIVE ERROR CRITERION INAPPROPRIATE
      if ct GT 0 then begin
          IDID = -3L
          Y = YY
          YPOUT = YP
          T = X
          TOLD = T
          INFO(1-1) = -1L
          INTOUT = 0L
          RETURN
      endif

      DDES_380:
      DDEABM_DSTEPS, DF,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, $
                YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, $
                TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,PRIVATE,FA, DFNAME, $
                max_stepsize=max_stepsize
      if ddeabm_funcerror NE 0 then return

; C
; C.......................................................................
; C
      IF (CRASH) THEN BEGIN
; C
; C                       TOLERANCES TOO SMALL
          IDID = -2L
          RTOL = EPS*RTOL
          ATOL = EPS*ATOL
          Y = YY
          YPOUT = YP
          T = X
          TOLD = T
          INFO(1-1) = -1L
          INTOUT = 0L
          RETURN
      ENDIF
; C
; C   (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE
; C   ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR
; C
  DDES_420:
      KLE4 = KLE4 + 1
      IF(KOLD GT 4) THEN KLE4 = 0L
      IF(KLE4 GE 50) THEN STIFF = 1L
      INTOUT = 1L
      GOTO, DDES_250
    END


; *DECK DDEABM_DINTP
pro DDEABM_DINTP, X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, $
       IV, KGI, GI, ALPHA, OG, OW, OX, OY
; C***BEGIN PROLOGUE  DDEABM_DINTP
; C***PURPOSE  Approximate the solution at XOUT by evaluating the
; C            polynomial computed in DDEABM_DSTEPS at XOUT.  Must be used in
; C            conjunction with DDEABM_DSTEPS.
; C***LIBRARY   SLATEC (DEPAC)
; C***CATEGORY  I1A1B
; C***TYPE      DOUBLE PRECISION (SINTRP-S, DINTP-D)
; C***KEYWORDS  ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE,
; C             ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR,
; C             SMOOTH INTERPOLANT
; C***AUTHOR  Watts, H. A., (SNLA)
; C***DESCRIPTION
; C
; C   The methods in subroutine  DDEABM_DSTEPS  approximate the solution near  X
; C   by a polynomial.  Subroutine  DDEABM_DINTP  approximates the solution at
; C   XOUT  by evaluating the polynomial there.  Information defining this
; C   polynomial is passed from  DDEABM_DSTEPS  so  DDEABM_DINTP  cannot be used alone.
; C
; C   Subroutine DDEABM_DSTEPS is completely explained and documented in the text
; C   "Computer Solution of Ordinary Differential Equations, the Initial
; C   Value Problem"  by L. F. Shampine and M. K. Gordon.
; C
; C   Input to DDEABM_DINTP --
; C
; C   The user provides storage in the calling program for the arrays in
; C   the call list
; C      DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN)
; C                AND ALPHA(12),OG(13),OW(12),GI(11),IV(10)
; C   and defines
; C      XOUT -- point at which solution is desired.
; C   The remaining parameters are defined in  DDEABM_DSTEPS  and passed to
; C   DDEABM_DINTP  from that subroutine
; C
; C   Output from  DDEABM_DINTP --
; C
; C      YOUT(*) -- solution at  XOUT
; C      YPOUT(*) -- derivative of solution at  XOUT
; C   The remaining parameters are returned unaltered from their input
; C   values.  Integration with  DDEABM_DSTEPS  may be continued.
; C
; C***REFERENCES  H. A. Watts, A smoother interpolant for DE/STEP, INTRP
; C                 II, Report SAND84-0293, Sandia Laboratories, 1984.
; C***ROUTINES CALLED  (NONE)
; C***REVISION HISTORY  (YYMMDD)
; C   840201  DATE WRITTEN
; C   890831  Modified array declarations.  (WRB)
; C   890831  REVISION DATE from Version 3.2
; C   891214  Prologue converted to Version 4.0 format.  (BAB)
; C   920501  Reformatted the REFERENCES section.  (WRB)
; C***END PROLOGUE  DDEABM_DINTP
; C
;       INTEGER I, IQ, IV, IVC, IW, J, JQ, KGI, KOLD, KP1, KP2,
;      1        L, M, NEQN
;       DOUBLE PRECISION ALP, ALPHA, C, G, GDI, GDIF, GI, GAMMA, H, HI,
;      1       HMU, OG, OW, OX, OY, PHI, RMU, SIGMA, TEMP1, TEMP2, TEMP3,
;      2       W, X, XI, XIM1, XIQ, XOUT, Y, YOUT, YPOUT
; C
;       DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*)
;       DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10)
; C
; C***FIRST EXECUTABLE STATEMENT  DDEABM_DINTP
      KP1 = KOLD + 1
      KP2 = KOLD + 2

      HI = XOUT - OX
      H = X - OX
      XI = HI/H
      XIM1 = XI - 1.D0

      G = DBLARR(13) & C = G & W = G
; C
; C   INITIALIZE W(*) FOR COMPUTING G(*)
; C
      XIQ = XI
      IQ = dindgen(kp1)+1
      XIQ = XI^(IQ+1)
      W(0:KP1-1) = XIQ/(IQ*(IQ+1))

; C
; C   COMPUTE THE DOUBLE INTEGRAL TERM GDI
; C
      IF (KOLD LE KGI) THEN BEGIN
          GDI = GI(KOLD-1)
          GOTO, DINTP_60
      ENDIF
          
      IF (IVC LE 0) THEN BEGIN
          GDI = 1.0D0/(KP1*(KP1+1))
          M = 2L
      ENDIF ELSE BEGIN
          IW = IV(IVC-1)
          GDI = OW(IW-1)
          M = KOLD - IW + 3
      ENDELSE

      IF (M LE KOLD) THEN BEGIN
;;        XXX:    (M>1) is a kludge
          FOR I = (M>1), KOLD DO $
            GDI = OW(KP2-I-1) - ALPHA(I-1)*GDI
      ENDIF

; C
; C   COMPUTE G(*) AND C(*)
; C
      DINTP_60:
      G(0:1) = [XI, XI^2/2]
      C(0:1) = [1d, XI]
      IF (KOLD GE 2) THEN BEGIN
          FOR I = 2L, KOLD DO BEGIN
              ALP = ALPHA(I-1)
              GAMMA = 1.0D0 + XIM1*ALP
              L = KP2 - I
              W(0:L-1) = GAMMA*W(0:L-1) - ALP*W(1:L)
              G(I) = W(0)
              C(I) = GAMMA*C(I-1)
          ENDFOR
      ENDIF
; C
; C   DEFINE INTERPOLATION PARAMETERS
; C
      SIGMA = (W(1) - XIM1*W(0))/GDI
      RMU = XIM1*C(KOLD)/GDI  ;; *** NOTE: KP1-1 is KOLD
      HMU = RMU/H

; C   INTERPOLATE FOR THE SOLUTION -- YOUT
; C   AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT

      YOUT(*) = 0
      YPOUT(*) = 0
      J = lindgen(KOLD)+1
      I = KP2 - J - 1 ;; *** NOTE: -1 is here
      GDIF = OG(I) - OG(I-1)
      TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF
      TEMP3 = (C(I) - C(I-1)) + RMU*GDIF

      FOR J = 0L, KOLD-1 DO BEGIN
        YOUT  = YOUT  + TEMP2(j)*PHI(*,I(j))
        YPOUT = YPOUT + TEMP3(j)*PHI(*,I(j))
      ENDFOR

      YOUT = ( ((1.0D0 - SIGMA)*OY + SIGMA*Y) + $
               H*(YOUT + (G(0) - SIGMA*OG(0))*PHI(*,0)) )
      YPOUT = ( HMU*(OY - Y) + $
                (YPOUT + (C(0) + RMU*OG(0))*PHI(*,0)) )

      RETURN
  END

; *DECK DDEABM_DSTEPS
  pro DDEABM_DSTEPS, DF, NEQN, Y, X, H, EPS, WT, START, HOLD, K, $
              KOLD, CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, $
              PHASE1, NS, NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, $
              KGI, GI, PRIVATE, FA, dfname, max_stepsize=max_stepsize
; C***BEGIN PROLOGUE  DDEABM_DSTEPS
; C***PURPOSE  Integrate a system of first order ordinary differential
; C            equations one step.
; C***LIBRARY   SLATEC (DEPAC)
; C***CATEGORY  I1A1B
; C***TYPE      DOUBLE PRECISION (STEPS-S, DSTEPS-D)
; C***KEYWORDS  ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE,
; C             ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR
; C***AUTHOR  Shampine, L. F., (SNLA)
; C           Gordon, M. K., (SNLA)
; C             MODIFIED BY H.A. WATTS
; C***DESCRIPTION
; C
; C   Written by L. F. Shampine and M. K. Gordon
; C
; C   Abstract
; C
; C   Subroutine  DDEABM_DSTEPS  is normally used indirectly through subroutine
; C   DDEABM .  Because  DDEABM  suffices for most problems and is much
; C   easier to use, using it should be considered before using  DDEABM_DSTEPS
; C   alone.
; C
; C   Subroutine DDEABM_DSTEPS integrates a system of  NEQN  first order ordinary
; C   differential equations one step, normally from X to X+H, using a
; C   modified divided difference form of the Adams Pece formulas.  Local
; C   extrapolation is used to improve absolute stability and accuracy.
; C   The code adjusts its order and step size to control the local error
; C   per unit step in a generalized sense.  Special devices are included
; C   to control roundoff error and to detect when the user is requesting
; C   too much accuracy.
; C
; C   This code is completely explained and documented in the text,
; C   Computer Solution of Ordinary Differential Equations, The Initial
; C   Value Problem  by L. F. Shampine and M. K. Gordon.
; C   Further details on use of this code are available in "Solving
; C   Ordinary Differential Equations with ODE, STEP, and INTRP",
; C   by L. F. Shampine and M. K. Gordon, SLA-73-1060.
; C
; C
; C   The parameters represent --
; C      DF -- subroutine to evaluate derivatives
; C      NEQN -- number of equations to be integrated
; C      Y(*) -- solution vector at X
; C      X -- independent variable
; C      H -- appropriate step size for next step.  Normally determined by
; C           code
; C      EPS -- local error tolerance
; C      WT(*) -- vector of weights for error criterion
; C      START -- logical variable set .TRUE. for first step,  .FALSE.
; C           otherwise
; C      HOLD -- step size used for last successful step
; C      K -- appropriate order for next step (determined by code)
; C      KOLD -- order used for last successful step
; C      CRASH -- logical variable set .TRUE. when no step can be taken,
; C           .FALSE. otherwise.
; C      YP(*) -- derivative of solution vector at  X  after successful
; C           step
; C      KSTEPS -- counter on attempted steps
; C      TWOU -- 2.*U where U is machine unit roundoff quantity
; C      FOURU -- 4.*U where U is machine unit roundoff quantity
; C      RPAR,IPAR -- parameter arrays which you may choose to use
; C            for communication between your program and subroutine F.
; C            They are not altered or used by DDEABM_DSTEPS.
; C   The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G,
; C   W,P,IV and GI are required for the interpolation subroutine SINTRP.
; C   The remaining variables and arrays are included in the call list
; C   only to eliminate local retention of variables between calls.
; C
; C   Input to DDEABM_DSTEPS
; C
; C      First call --
; C
; C   The user must provide storage in his calling program for all arrays
; C   in the call list, namely
; C
; C     DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12),
; C    1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10),
; C    2  RPAR(*),IPAR(*)
; C
; C    **Note**
; C
; C   The user must also declare  START ,  CRASH ,  PHASE1  and  NORND
; C   logical variables and  DF  an EXTERNAL subroutine, supply the
; C   subroutine  DF(X,Y,YP)  to evaluate
; C      DY(I)/DX = YP(I) = DF(X,Y(1),Y(2),...,Y(NEQN))
; C   and initialize only the following parameters.
; C      NEQN -- number of equations to be integrated
; C      Y(*) -- vector of initial values of dependent variables
; C      X -- initial value of the independent variable
; C      H -- nominal step size indicating direction of integration
; C           and maximum size of step.  Must be variable
; C      EPS -- local error tolerance per step.  Must be variable
; C      WT(*) -- vector of non-zero weights for error criterion
; C      START -- .TRUE.
; C      YP(*) -- vector of initial derivative values
; C      KSTEPS -- set KSTEPS to zero
; C      TWOU -- 2.*U where U is machine unit roundoff quantity
; C      FOURU -- 4.*U where U is machine unit roundoff quantity
; C   Define U to be the machine unit roundoff quantity by calling
; C   the function routine  D1MACH,  U = D1MACH(4), or by
; C   computing U so that U is the smallest positive number such
; C   that 1.0+U .GT. 1.0.
; C
; C   DDEABM_DSTEPS  requires that the L2 norm of the vector with components
; C   LOCAL ERROR(L)/WT(L)  be less than  EPS  for a successful step.  The
; C   array  WT  allows the user to specify an error test appropriate
; C   for his problem.  For example,
; C      WT(L) = 1.0  specifies absolute error,
; C            = ABS(Y(L))  error relative to the most recent value of the
; C                 L-th component of the solution,
; C            = ABS(YP(L))  error relative to the most recent value of
; C                 the L-th component of the derivative,
; C            = MAX(WT(L),ABS(Y(L)))  error relative to the largest
; C                 magnitude of L-th component obtained so far,
; C            = ABS(Y(L))*RELERR/EPS + ABSERR/EPS  specifies a mixed
; C                 relative-absolute test where  RELERR  is relative
; C                 error,  ABSERR  is absolute error and  EPS =
; C                 MAX(RELERR,ABSERR) .
; C
; C      Subsequent calls --
; C
; C   Subroutine  DDEABM_DSTEPS  is designed so that all information needed to
; C   continue the integration, including the step size  H  and the order
; C   K , is returned with each step.  With the exception of the step
; C   size, the error tolerance, and the weights, none of the parameters
; C   should be altered.  The array  WT  must be updated after each step
; C   to maintain relative error tests like those above.  Normally the
; C   integration is continued just beyond the desired endpoint and the
; C   solution interpolated there with subroutine  SINTRP .  If it is
; C   impossible to integrate beyond the endpoint, the step size may be
; C   reduced to hit the endpoint since the code will not take a step
; C   larger than the  H  input.  Changing the direction of integration,
; C   i.e., the sign of  H , requires the user set  START = .TRUE. before
; C   calling  DDEABM_DSTEPS  again.  This is the only situation in which  START
; C   should be altered.
; C
; C   Output from DDEABM_DSTEPS
; C
; C      Successful Step --
; C
; C   The subroutine returns after each successful step with  START  and
; C   CRASH  set .FALSE. .  X  represents the independent variable
; C   advanced one step of length  HOLD  from its value on input and  Y
; C   the solution vector at the new value of  X .  All other parameters
; C   represent information corresponding to the new  X  needed to
; C   continue the integration.
; C
; C      Unsuccessful Step --
; C
; C   When the error tolerance is too small for the machine precision,
; C   the subroutine returns without taking a step and  CRASH = .TRUE. .
; C   An appropriate step size and error tolerance for continuing are
; C   estimated and all other information is restored as upon input
; C   before returning.  To continue with the larger tolerance, the user
; C   just calls the code again.  A restart is neither required nor
; C   desirable.
; C
; C***REFERENCES  L. F. Shampine and M. K. Gordon, Solving ordinary
; C                 differential equations with ODE, STEP, and INTRP,
; C                 Report SLA-73-1060, Sandia Laboratories, 1973.
; C***ROUTINES CALLED  D1MACH, DDEABM_DHSTRT
; C***REVISION HISTORY  (YYMMDD)
; C   740101  DATE WRITTEN
; C   890531  Changed all specific intrinsics to generic.  (WRB)
; C   890831  Modified array declarations.  (WRB)
; C   890831  REVISION DATE from Version 3.2
; C   891214  Prologue converted to Version 4.0 format.  (BAB)
; C   920501  Reformatted the REFERENCES section.  (WRB)
; C***END PROLOGUE  DDEABM_DSTEPS
; C
;       INTEGER I, IFAIL, IM1, IP1, IPAR, IQ, J, K, KM1, KM2, KNEW,
;      1      KOLD, KP1, KP2, KSTEPS, L, LIMIT1, LIMIT2, NEQN, NS, NSM2,
;      2      NSP1, NSP2
;       DOUBLE PRECISION ABSH, ALPHA, BETA, BIG, D1MACH,
;      1      EPS, ERK, ERKM1, ERKM2, ERKP1, ERR,
;      2      FOURU, G, GI, GSTR, H, HNEW, HOLD, P, P5EPS, PHI, PSI, R,
;      3      REALI, REALNS, RHO, ROUND, RPAR, SIG, TAU, TEMP1,
;      4      TEMP2, TEMP3, TEMP4, TEMP5, TEMP6, TWO, TWOU, U, V, W, WT,
;      5      X, XOLD, Y, YP
;       LOGICAL START,CRASH,PHASE1,NORND
;       DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12),
;      1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10),
;      2  RPAR(*),IPAR(*)
;       DIMENSION TWO(13),GSTR(13)
;       EXTERNAL DF
;       SAVE TWO, GSTR

;       DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8),
;      1     TWO(9),TWO(10),TWO(11),TWO(12),TWO(13)
;      2     /2.0D0,4.0D0,8.0D0,16.0D0,32.0D0,64.0D0,128.0D0,256.0D0,
;      3      512.0D0,1024.0D0,2048.0D0,4096.0D0,8192.0D0/
;       DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7),
;      1     GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13)
;      2     /0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0,
;      3      0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0/

    common ddeabm_func_common
    TWO = 2d^(dindgen(13)+1)
    GSTR = [ 0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0, $
             0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0 ]

; C
; C       ***     BEGIN BLOCK 0     ***
; C   CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE
; C   PRECISION.  IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A
; C   STARTING STEP SIZE.
; C                   ***
; C
; C   IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE
; C
; C***FIRST EXECUTABLE STATEMENT  DDEABM_DSTEPS
      CRASH = 1L
      IF (ABS(H) LT FOURU*ABS(X)) THEN BEGIN
          H = (FOURU*ABS(X)) * ( (H GE 0)?(+1):(-1) )
          RETURN
      ENDIF

      P5EPS = 0.5D0*EPS
; C
; C   IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE
; C
      ROUND = TOTAL( (Y/WT)^2 )
      ROUND = TWOU*SQRT(ROUND)

      IF (P5EPS LT ROUND) THEN BEGIN
          EPS = 2.0D0*ROUND*(1.0D0 + FOURU)
          RETURN
      ENDIF

      CRASH = 0L
      G(0) = 1.0D0
      G(1) = 0.5D0
      SIG(0) = 1.0D0
      IF (NOT START) THEN GOTO, DSTEPS_99
; C
; C   INITIALIZE.  COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP
; C
; C     CALL DF(X,Y,YP,RPAR,IPAR)
; C     SUM = 0.0
      PHI(*,0) = YP
      PHI(*,1) = 0
; C20     SUM = SUM + (YP(L-1)/WT(L-1))**2
; C     SUM = SQRT(SUM)
; C     ABSH = ABS(H)
; C     IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM)
; C     H = SIGN(MAX(ABSH,FOURU*ABS(X)),H)
; C
      U = (machar(/double)).eps          ;; XXX
      BIG = SQRT((machar(/double)).xmax) ;; XXX


      ;; Save and restore values from PHI
      phi3 = phi(*,2) & phi4 = phi(*,3)
      phi5 = phi(*,4) & phi6 = phi(*,5)
      DDEABM_DHSTRT, DF,NEQN,X,X+H,Y,YP,WT,1,U,BIG, $
        phi3, phi4, phi5, phi6, private, fa, h, dfname
      phi(*,2) = phi3 & phi(*,3) = phi4 
      phi(*,4) = phi5 & phi(*,5) = phi6
      if ddeabm_funcerror NE 0 then return

      HOLD = 0.0D0
      K = 1L
      KOLD = 0L
      KPREV = 0L
      START = 0L
      PHASE1 = 1L
      NORND = 1L
      IF (P5EPS LE 100.0D0*ROUND) THEN BEGIN
          NORND = 0L
          PHI(*,14) = 0
      ENDIF

      DSTEPS_99:
      IFAIL = 0L
; C       ***     END BLOCK 0     ***
; C
; C       ***     BEGIN BLOCK 1     ***
; C   COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP.  AVOID COMPUTING
; C   THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED.
; C                   ***
; C
      DSTEPS_100:
      KP1 = K+1
      KP2 = K+2
      KM1 = K-1
      KM2 = K-2
; C
; C   NS IS THE NUMBER OF DSTEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT
; C   ONE.  WHEN K.LT.NS, NO COEFFICIENTS CHANGE
; C
      IF (H NE HOLD) THEN NS = 0L
      IF (NS LE KOLD) THEN NS = NS+1
      NSP1 = NS+1
      IF (K LT NS) THEN GOTO, DSTEPS_199
; C
; C   COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH
; C   ARE CHANGED
; C
      BETA(NS-1) = 1.0D0
      ALPHA(NS-1) = 1.0D0/NS
      TEMP1 = H*NS
      SIG(NSP1-1) = 1.0D0
      IF (K GE NSP1) THEN BEGIN
          FOR I = NSP1, K DO BEGIN
              IM1 = I-1-1  ;; *** Note IM1-1 here!
              II = I-1
              TEMP2 = PSI(IM1)
              PSI(IM1) = TEMP1
              BETA(II) = BETA(IM1)*PSI(IM1)/TEMP2
              TEMP1 = TEMP2 + H
              ALPHA(II) = H/TEMP1
              SIG(I) = I*ALPHA(II)*SIG(II)
          ENDFOR
      ENDIF
      PSI(K-1) = TEMP1
; C
; C   COMPUTE COEFFICIENTS G(*)
; C
; C   INITIALIZE V(*) AND SET W(*).
; C
      IF (NS LE 1) THEN BEGIN
          KK = dindgen(K)+1
          V(0:K-1) = 1.0D0/(KK*(KK+1))
          W(0:K-1) = V(0:K-1)
          IVC = 0L
          KGI = 0L
          IF (K EQ 1) THEN GOTO, DSTEPS_140
          KGI = 1L
          GI(0) = W(1)
          GOTO, DSTEPS_140
      ENDIF
; C
; C   IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*)
; C
      IF (K LE KPREV) THEN GOTO, DSTEPS_130
      IF (IVC NE 0) THEN BEGIN 
          JV = KP1 - IV(IVC-1)
          IVC = IVC - 1
      ENDIF ELSE BEGIN
          JV = 1L
          TEMP4 = K*KP1
          V(K-1) = 1.0D0/TEMP4
          W(K-1) = V(K-1)
          IF (K EQ 2) THEN BEGIN
              KGI = 1L
              GI(0) = W(1)
          ENDIF
      ENDELSE
      NSM2 = NS-2
      IF (NSM2 GE JV) THEN BEGIN
          
          FOR J = JV, NSM2 DO BEGIN
              I = K-J-1  ;; *** NOTE: I-1 here!
              V(I) = V(I) - ALPHA(J)*V(I+1)
              W(I) = V(I)
          ENDFOR

          IF (I EQ 2) THEN BEGIN
              KGI = NS - 1
              GI(KGI-1) = W(1)
          ENDIF
      ENDIF
; C
; C   UPDATE V(*) AND SET W(*)
; C
      DSTEPS_130:
      LIMIT1 = KP1 - NS
      TEMP5 = ALPHA(NS-1)
      V(0:LIMIT1-1) = V(0:LIMIT1-1) - TEMP5*V(1:LIMIT1)
      W(0:LIMIT1-1) = V(0:LIMIT1-1)
      G(NSP1-1) = W(0)
      IF (LIMIT1 NE 1) THEN BEGIN
          KGI = NS
          GI(KGI-1) = W(1)
      ENDIF
      W(LIMIT1) = V(LIMIT1)
      IF (K LT KOLD) THEN BEGIN 
          IVC = IVC + 1
          IV(IVC-1) = LIMIT1 + 2
      ENDIF
; C
; C   COMPUTE THE G(*) IN THE WORK VECTOR W(*)
; C
      DSTEPS_140:
      NSP2 = NS + 2
      KPREV = K
      IF (KP1 GE NSP2) THEN BEGIN
          FOR I = NSP2, KP1 DO BEGIN
              LIMIT2 = KP2 - I
              TEMP6 = ALPHA(I-2)
              W(0:LIMIT2-1) = W(0:LIMIT2-1) - TEMP6*W(1:LIMIT2)
              G(I-1) = W(0)
          ENDFOR
      ENDIF

      DSTEPS_199:
; C       ***     END BLOCK 1     ***
; C
; C       ***     BEGIN BLOCK 2     ***
; C   PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED
; C   SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K,
; C   K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED.
; C                   ***
; C
; C   INCREMENT COUNTER ON ATTEMPTED DSTEPS
; C
      KSTEPS = KSTEPS + 1
; C
; C   CHANGE PHI TO PHI STAR
; C
      IF (K GE NSP1) THEN BEGIN
          FOR I = NSP1, K DO BEGIN
              TEMP1 = BETA(I-1)
              PHI(*,I-1) = TEMP1*PHI(*,I-1)
          ENDFOR
      ENDIF
; C
; C   PREDICT SOLUTION AND DIFFERENCES
; C
      PHI(*,KP2-1) = PHI(*,KP1-1)
      PHI(*,KP1-1) = 0
      P(*) = 0
      FOR J = 1L, K DO BEGIN
        I = KP1 - J - 1 ;; *** NOTE: I-1 here!
        TEMP2 = G(I)
        P = P + TEMP2*PHI(*,I)
        PHI(*,I) = PHI(*,I) + PHI(*,I+1)
      ENDFOR
      IF NOT (NORND) THEN BEGIN
          TAU = H*P - PHI(*,14)
          P = Y + TAU
          PHI(*,15) = (P - Y) - TAU
      ENDIF ELSE BEGIN
          P = Y + H*P
      ENDELSE
      XOLD = X

      X = X + H
      ABSH = ABS(H)

      YP = CALL_FUNCTION(DFNAME, DF, X, P, PRIVATE, _EXTRA=FA)
      if ddeabm_funcerror NE 0 then return

; C
; C   ESTIMATE ERRORS AT ORDERS K,K-1,K-2
; C
      ERKM2 = 0.0D0
      ERKM1 = 0.0D0
      TEMP3 = 1.0D0/WT
      TEMP4 = YP - PHI(*,0)
      ERK = total((temp4*temp3)^2)
      IF (KM2 GT 0) THEN $
        ERKM2 = TOTAL( ((PHI(*,KM1-1)+TEMP4)*TEMP3)^2 )
      IF (KM2 GE 0) THEN $
        ERKM1 = TOTAL( ((PHI(*,K-1)+TEMP4)*TEMP3)^2 )

      IF (KM2 GT 0) THEN $
        ERKM2 = ABSH*SIG(KM1-1)*GSTR(KM2-1)*SQRT(ERKM2)
      IF (KM2 GE 0) THEN $
        ERKM1 = ABSH*SIG(K-1)*GSTR(KM1-1)*SQRT(ERKM1)
      TEMP5 = ABSH*SQRT(ERK)
      ERR = TEMP5*(G(K-1)-G(KP1-1))
      ERK = TEMP5*SIG(KP1-1)*GSTR(K-1)
      KNEW = K
; C
; C   TEST IF ORDER SHOULD BE LOWERED
; C
      IF (KM2 GT 0) THEN BEGIN
          IF(MAX([ERKM1,ERKM2]) LE ERK) THEN KNEW = KM1
      ENDIF ELSE IF (KM2 EQ 0) THEN BEGIN
          IF(ERKM1 LE 0.5D0*ERK) THEN KNEW = KM1
      ENDIF
; C
; C   TEST IF STEP SUCCESSFUL
; C
      IF (ERR LE EPS) THEN GOTO, DSTEPS_400
; C       ***     END BLOCK 2     ***
; C
; C       ***     BEGIN BLOCK 3     ***
; C   THE STEP IS UNSUCCESSFUL.  RESTORE  X, PHI(*,*), PSI(*) .
; C   IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE.  IF STEP FAILS MORE
; C   THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE.  DOUBLE ERROR
; C   TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE
; C   PRECISION.
; C                   ***
; C
; C   RESTORE X, PHI(*,*) AND PSI(*)
; C
      PHASE1 = 0L
      X = XOLD
      FOR I = 0L, K-1 DO BEGIN
        PHI(*,I) = (PHI(*,I) - PHI(*,I+1))/BETA(I)
      ENDFOR
      IF (K GE 2) THEN BEGIN 
          PSI(0:K-2) = PSI(1:K-1) - H
      ENDIF

; C
; C   ON THIRD FAILURE, SET ORDER TO ONE.  THEREAFTER, USE OPTIMAL STEP
; C   SIZE
; C
      IFAIL = IFAIL + 1
      TEMP2 = 0.5D0
      IF (IFAIL - 3 GT 0) THEN BEGIN
          IF (P5EPS LT 0.25D0*ERK) THEN TEMP2 = SQRT(P5EPS/ERK)
      ENDIF
      IF (IFAIL - 3 GE 0) THEN KNEW = 1L
      H = TEMP2*H
      K = KNEW
      NS = 0L
      IF (ABS(H) LT FOURU*ABS(X)) THEN BEGIN
          CRASH = 1L
          H = (FOURU*ABS(X))*( (H GE 0)?(+1):(-1) )
          EPS = EPS + EPS
          RETURN
      ENDIF

      GOTO, DSTEPS_100
; C       ***     END BLOCK 3     ***
; C
; C       ***     BEGIN BLOCK 4     ***
; C   THE STEP IS SUCCESSFUL.  CORRECT THE PREDICTED SOLUTION, EVALUATE
; C   THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE
; C   DIFFERENCES.  DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP.
; C                   ***
      DSTEPS_400:
      KOLD = K
      HOLD = H
; C
; C   CORRECT AND EVALUATE
; C
      TEMP1 = H*G(KP1-1)
      IF NOT (NORND) THEN BEGIN
          
          TEMP3 = Y
          RHO = TEMP1*(YP - PHI(*,0)) - PHI(*,15)
          Y = P + RHO
          PHI(*,14) = (Y - P) - RHO
          P = TEMP3
      ENDIF ELSE BEGIN
          TEMP3 = Y
          Y = P + TEMP1*(YP - PHI(*,0))
          P = TEMP3
      ENDELSE

      YP = CALL_FUNCTION(DFNAME, DF, X, Y, PRIVATE, _EXTRA=FA)
      if ddeabm_funcerror NE 0 then return


; C
; C   UPDATE DIFFERENCES FOR NEXT STEP
; C
      PHI(*,KP1-1) = YP - PHI(*,0)
      PHI(*,KP2-1) = PHI(*,KP1-1) - PHI(*,KP2-1)
      FOR I = 0L, K-1 DO BEGIN
          PHI(*,I) = PHI(*,I) + PHI(*,KP1-1)
      ENDFOR
; C
; C   ESTIMATE ERROR AT ORDER K+1 UNLESS:
; C     IN FIRST PHASE WHEN ALWAYS RAISE ORDER,
; C     ALREADY DECIDED TO LOWER ORDER,
; C     STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE
; C
      ERKP1 = 0.0D0
      IF (KNEW EQ KM1  OR  K EQ 12) THEN PHASE1 = 0L
      IF (PHASE1) THEN GOTO, DSTEPS_450
      IF (KNEW EQ KM1) THEN GOTO, DSTEPS_455
      IF (KP1 GT NS) THEN GOTO, DSTEPS_460
      ERKP1 = TOTAL( (PHI(*,KP2-1)/WT)^2 )
      ERKP1 = ABSH*GSTR(KP1-1)*SQRT(ERKP1)
; C
; C   USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER
; C   FOR NEXT STEP
; C
      IF (K LE 1) THEN BEGIN
          IF (ERKP1 GE 0.5D0*ERK) THEN GOTO, DSTEPS_460
      ENDIF ELSE BEGIN
          IF (ERKM1 LE MIN([ERK,ERKP1])) THEN GOTO, DSTEPS_455
          IF (ERKP1 GE ERK  OR  K EQ 12) THEN GOTO, DSTEPS_460
      ENDELSE
; C
; C   HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE
; C   BEEN LOWERED IN BLOCK 2.  THUS ORDER IS TO BE RAISED
; C
; C   RAISE ORDER
; C
      DSTEPS_450:
      K = KP1
      ERK = ERKP1
      GOTO, DSTEPS_460
; C
; C   LOWER ORDER
; C
      DSTEPS_455:
      K = KM1
      ERK = ERKM1
; C
; C   WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP
; C
      DSTEPS_460:
      HNEW = H + H
      IF NOT ( (PHASE1) OR $
               (P5EPS GE ERK*TWO(K)) ) THEN BEGIN
          HNEW = H
          IF (P5EPS LT ERK) THEN BEGIN
              TEMP2 = K+1
              R = (P5EPS/ERK)^(1.0D0/TEMP2)
              HNEW = ABSH*MAX([0.5D0,MIN([0.9D0,R])])
              HNEW = MAX([HNEW,FOURU*ABS(X)])
              HNEW = (H GE 0)?(+HNEW):(-HNEW)
          ENDIF
      ENDIF

      if n_elements(max_stepsize) GT 0 then begin
          HNEW = HNEW < max_stepsize(0) > (-max_stepsize(0))
      endif

      H = HNEW
      RETURN
; C       ***     END BLOCK 4     ***
  END


; ------------------------------------------------------------------------

pro DDEABM, DF, T, Y, TOUT0, PRIVATE, FUNCTARGS=fa, STATE=state, $
            CONTROL=control, $
            init=init0, intermediate=intermediate, tstop=TSTOP0, $
            epsrel=RTOL, epsabs=ATOL, status=IDID, $
            TGRID=tgrid, YGRID=ygrid, YPGRID=ypgrid, $
            NGRID=ngrid0, NOUTGRID=nsamp, $
            TIMPULSE=timpulse, YIMPULSE=yimpulse, $
            MAX_STEPSIZE=max_stepsize, $
            NFEV=nfev, errmsg=errmsg, dostatusline=dostatusline

      common ddeabm_func_common, ddeabm_nfev, ddeabm_funcerror

      IDID = -33
      errmsg = ''
      if n_params() EQ 0 then begin
          message, 'USAGE:', /info
          message, '  DDEABM, FUNCNAME, T0, Y0, TOUT, STATE, PRIVATE, '+$
            'FUNCTARGS=fa, INIT=init, [EPSREL=epsrel, EPSABS=epsabs, '+$
            'STATUS=status, /INTERMEDIATE, ...]', /info
          return
      endif

; C***FIRST EXECUTABLE STATEMENT  DDEABM
      NEQ = N_ELEMENTS(Y)

      IF NEQ LT 1 THEN BEGIN
          errmsg = 'The number of equations, NEQ, must be greater than '+$
            'or equal to 1'
          idid = -33L
          RETURN
      ENDIF

      ;; Initialize the number of function evaluations
      ddeabm_nfev = 0L
      nfev = 0L

      ;; Construct the wrapper function to be used
      dfname = 'ddeabm_func'
      dfname = dfname + ((n_elements(private) GT 0)?'1':'0')
      dfname = dfname + ((n_elements(fa) GT 0     )?'e':'n')
      
      ;; If either of the tolerances are undefined, then define with
      ;; default tolerances and with the same number of elements
      if n_elements(rtol) EQ 0 AND n_elements(atol) EQ 0 then begin
          rtol = 1d-4
          atol = 1d-6
      endif else if n_elements(rtol) GT 0 AND n_elements(atol) EQ 0 then begin
          atol = rtol*0d
      endif else if n_elements(atol) GT 0 AND n_elements(rtol) EQ 0 then begin
          rtol = atol*0D
      endif

      ;; Compare to be sure the same number 
      if n_elements(rtol) NE n_elements(atol) $
        OR (n_elements(y) NE n_elements(rtol) AND n_elements(rtol) NE 1) $
        then begin
          errmsg = 'The number of absolute and relative tolerance values '+ $
            'must match the number of equations being solved.'
          idid = -33L
      endif

      ;; Be sure to initialize if there is no state variable
      ;; NOTE: DDEABM uses INIT=0 to mean initialize; INIT=1 means
      ;;       don't initialize, which is the opposite sense from the
      ;;       input keyword.
      userinit = 1-keyword_set(init0)
      if n_elements(state) EQ 0 then userinit = 0L

      ;; Construct the INFO array from keywords
      INFO = [ userinit, n_elements(rtol) GT 1, $
               keyword_set(intermediate), n_elements(tstop0) GT 0]

      ;; Construct the STATE array if this is the first pass
      IF ( INFO(1-1) EQ 0 ) OR N_ELEMENTS(STATE) EQ 0 THEN BEGIN
          STATE = {YPOUT: dblarr(neq), TSTAR: 0D, YP: dblarr(NEQ), $
                   YY: dblarr(NEQ), WT: dblarr(NEQ), P: dblarr(NEQ), $
                   PHI: dblarr(NEQ,16), ALPHA: dblarr(12), BETA: dblarr(12), $
                   PSI: dblarr(12), V: dblarr(12), W: dblarr(12), $
                   SIG: dblarr(13), G: dblarr(13), GI: dblarr(11), $
                   XOLD: 0D, HOLD: 0D, TOLD: 0D, DELSN: 0D, TWOU: 0D, $
                   FOURU: 0D, H: 0D, EPS: 0D, X: 0D, TSTOP: 0D, $
                   START: 0L, PHASE1: 0L, NORND: 0L, STIFF: 0L, $
                   INTOUT: 0L, NS: 0L, KORD: 0L, KOLD: 0L, INTERNAL_INIT: 0L, $
                   KSTEPS: 0L, KLE4: 0L, IQUIT: 0L, KPREV: 0L, IVC: 0L, $
                   IV: lonarr(10), KGI: 0L, NEQ: NEQ, COUNT: 0L}
      ENDIF

      if n_elements(tstop0) GT 0 then $
        state.tstop = tstop0(0)

      IF (STATE.COUNT GE 5) THEN BEGIN
         IF (T EQ STATE.TSTAR) THEN BEGIN
             errmsg = 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.  '+ $
               'YOU HAVE MADE REPEATED CALLS AT T = '+strtrim(t,2)+ $
               ' AND THE INTEGRATION HAS NOT ADVANCED.  CHECK THE '+ $
               'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE '+ $
               'CODE, PARTICULARLY INFO(1-1).'
             RETURN
         ENDIF
     ENDIF

     IF NEQ NE STATE.NEQ THEN BEGIN
         errmsg = 'You have initialized DDEABM with a different number '+$
           'of equations, NEQ, than this call has provided.'
         RETURN
     ENDIF
; C
; C     CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION
; C
      IDID=0L
; C
; C     COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY
; C
     YPOUT = STATE.YPOUT
     TSTAR = STATE.TSTAR
     YP    = STATE.YP   
     YY    = STATE.YY   
     WT    = STATE.WT   
     P     = STATE.P    
     PHI   = STATE.PHI  
     ALPHA = STATE.ALPHA
     BETA  = STATE.BETA 
     PSI   = STATE.PSI  
     V     = STATE.V    
     W     = STATE.W    
     SIG   = STATE.SIG  
     G     = STATE.G    
     GI    = STATE.GI   
     XOLD  = STATE.XOLD 
     HOLD  = STATE.HOLD 
     TOLD  = STATE.TOLD 
     DELSN = STATE.DELSN
     TWOU  = STATE.TWOU 
     FOURU = STATE.FOURU

     H     = STATE.H
     EPS   = STATE.EPS
     X     = STATE.X
     TSTOP = STATE.TSTOP


     STATE.TSTAR = T

      IF (INFO(1-1) NE 0) THEN BEGIN
          START = STATE.START
          PHASE1 = STATE.PHASE1
          NORND = STATE.NORND
          STIFF = STATE.STIFF
          INTOUT = STATE.INTOUT
      ENDIF
      
     NS     = STATE.NS
     KORD   = STATE.KORD
     KOLD   = STATE.KOLD
     INTERNAL_INIT   = STATE.INTERNAL_INIT
     KSTEPS = STATE.KSTEPS
     KLE4   = STATE.KLE4
     IQUIT  = STATE.IQUIT
     KPREV  = STATE.KPREV
     IVC    = STATE.IVC
     IV     = STATE.IV
     KGI    = STATE.KGI

     if n_elements(ngrid0) GT 0 then begin
         if NOT keyword_set(intermediate) then begin
             errmsg = 'ERROR: NGRID and /INTERMEDIATE must be specified '+$
               'together'
             return
         endif
         ngrid = round(ngrid0(0))
     endif else begin
         ngrid = n_elements(tout0)
     endelse

     tgrid = dblarr(ngrid)
     ygrid = dblarr(neq, ngrid)
     ypgrid = dblarr(neq, ngrid)
     forward = tout0(0) GT t     ;; 1=FORWARD; 0=BACKWARD

     ki = 1L
     nimpulse = n_elements(timpulse)
     if nimpulse GT 0 then begin
         if nimpulse NE n_elements(yimpulse)/neq then begin
             errmsg = 'ERROR: TIMPULSE and YIMPULSE must have the same '+$
               'number of samples'
             return
         endif

         if forward then begin
             wh = where(timpulse GT tout0(0), ct)
             if ct EQ 0 then ki = nimpulse else ki = min(wh)
         endif else begin
             wh = where(timpulse LT tout0(0), ct)
             if ct EQ 0 then ki = 0L else ki = max(wh)
         endelse

     endif

     ;; Initialize the user function
     if info(1-1) EQ 0 AND keyword_set(control) then begin
         ddeabm_funcerror = call_function(dfname, df, t, $
                                          CONTROL={message: 'INITIALIZE'}, $
                                          y, private, _EXTRA=fa)
         if ddeabm_funcerror LT 0 then begin
             errmsg = 'ERROR: user function failed to initialize'
             goto, FINISH_INTEGRATION
         endif
     endif


     i = 0L   ;; Output grid position counter
     nsamp = 0L
     while (i LT ngrid) do begin
         if keyword_set(dostatusline) then $
           statusline, string(i, ngrid, format='(I8,"/",I8)'), 0, /left
         doimpulse = 0  ;; Signal to process an impulse (0=no; 1=yes; 2=both)
         if keyword_set(intermediate) then begin
             TOUT = TOUT0(0)
         endif else begin
             TOUT = TOUT0(i)

             if (ki GE 0) AND (ki LT nimpulse) then begin
                 if abs(timpulse(ki)-t) LE abs(tout-t) then begin
                     doimpulse = 1
                     if TIMPULSE(ki) EQ TOUT then doimpulse = 2
                     TOUT = TIMPULSE(ki)
                 endif
             endif
         endelse

         ddeabm_funcerror = 0
         DDEABM_DDES, DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,YPOUT, $
           YP,YY,WT,P,PHI, $
           ALPHA,BETA,PSI,V, $
           W,SIG,G,GI,H, $
           EPS,X,XOLD,HOLD, $
           TOLD,DELSN,TSTOP,TWOU, $
           FOURU,START,PHASE1,NORND,STIFF,INTOUT, NS, KORD, KOLD, INTERNAL_INIT, $
           KSTEPS, KLE4, IQUIT, KPREV, IVC, IV, KGI, PRIVATE, FA, dfname, $
           ERRMSG=errmsg, max_stepsize=max_stepsize

         if ddeabm_funcerror NE 0 then begin
             case ddeabm_funcerror of
                 -16:  errmsg = 'ERROR: user function returned non-finite values'
                 else: errmsg = 'ERROR: unknown internal error occurred'
             endcase
             goto, FINISH_INTEGRATION
         endif

         if IDID GT 0 then begin

             ;; === Store the result
             if (doimpulse EQ 0) OR (doimpulse EQ 2) then begin
                 ;; This was not an impulse-only stopping point...
                 ;; Store the result
                 tgrid(i) = T
                 ygrid(*,i) = Y
                 ypgrid(*,i) = YPOUT
                 nsamp = nsamp + 1
                 i = i + 1
             endif

             ;; === Handle any impulse changes
             if (doimpulse GT 0) then begin    
                 ;; Apply an impulse
                 if forward then begin
                     Y = Y + YIMPULSE(*,ki)
                     ki = ki + 1
                 endif else begin
                     Y = Y - YIMPULSE(*,ki)
                     ki = ki - 1
                 endelse

                 ;; Special case: the same TOUT can be listed twice
                 ;;   for before and after an impulse.  In that case
                 ;;   store the same values after we have incremented.
                 if (doimpulse EQ 2) then if (TOUT0(i) EQ TOUT0(i-1)) then begin
                     tgrid(i) = T
                     ygrid(*,i) = Y
                     ;; We have to re-call the function since we
                     ;; crossed the discontinuity.
                     ypgrid(*,i) = call_function(dfname,df, t, y, private,_EXTRA=fa)
                     nsamp = nsamp + 1
                     i = i + 1
                 endif

                 doimpulse = 0
                 info(1-1) = 0L  ;; NOTE that INIT=0 means initialize!!!
             endif

             ;; Reset KSTEPS since we successfully integrated this step
             ksteps = 0L

             ;; End if we reach the stopping point early
             if keyword_set(intermediate) then begin
                 if idid EQ 2 OR idid EQ 3 OR t EQ tout(0) then $
                   goto, FINISH_INTEGRATION
             endif

         endif else begin
             goto, FINISH_INTEGRATION
         endelse

     endwhile

     FINISH_INTEGRATION:

     STATE.YPOUT = YPOUT
     STATE.YP    = YP   
     STATE.YY    = YY   
     STATE.WT    = WT   
     STATE.P     = P    
     STATE.PHI   = PHI  
     STATE.ALPHA = ALPHA
     STATE.BETA  = BETA 
     STATE.PSI   = PSI  
     STATE.V     = V    
     STATE.W     = W    
     STATE.SIG   = SIG  
     STATE.G     = G    
     STATE.GI    = GI   
     STATE.XOLD  = XOLD 
     STATE.HOLD  = HOLD 
     STATE.TOLD  = TOLD 
     STATE.DELSN = DELSN
     STATE.TWOU  = TWOU 
     STATE.FOURU = FOURU
      
     STATE.H     = H
     STATE.EPS   = EPS
     STATE.X     = X
     STATE.TSTOP = TSTOP

     STATE.NS     = NS
     STATE.KORD   = KORD
     STATE.KOLD   = KOLD
     STATE.INTERNAL_INIT   = INTERNAL_INIT
     STATE.KSTEPS = KSTEPS
     STATE.KLE4   = KLE4
     STATE.IQUIT  = IQUIT
     STATE.KPREV  = KPREV
     STATE.IVC    = IVC
     STATE.IV     = IV
     STATE.KGI    = KGI

     STATE.START  = START
     STATE.PHASE1 = PHASE1
     STATE.NORND  = NORND
     STATE.STIFF  = STIFF
     STATE.INTOUT = INTOUT
     NFEV = DDEABM_NFEV

     ;; Pass back INIT to user, and remember to invert the sense
     ;; between the internal variable and the external variable.
     INIT0 = (info(0) EQ 0)
     TSTOP0 = STATE.TSTOP
     ;; XXX what to do about interrupted case where INFO(1-1) is
     ;; negative, and the user must reset it?
     ;; Answer: Add RESUME keyword, and enforce the behavior that
     ;; RESUME must only be set after an interruption.  Must save one
     ;; more variable in STATE with the previous INFO(1-1) value.

      IF (IDID NE (-2)) THEN STATE.COUNT = STATE.COUNT + 1L
      IF (T NE STATE.TSTAR) THEN STATE.COUNT = 0L

      if keyword_set(dostatusline) then begin
          statusline, /close
      endif

      RETURN
      END
;+
; NAME:
;   DEFSUBCELL
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Returns a default subcell suitable for plotting in.
;
; CALLING SEQUENCE:
;   sub = defsubcell( [default] )
;
; DESCRIPTION: 
;
;   DEFSUBCELL returns a "nice" subcell, useful for plotting in.  It
;   gives 8% margins on the left and bottom, and 5% margins on the
;   right and top.
;
;   A set of user-defined default values can be passed in.  Any that
;   are negative are replaced by this function's.
;
; INPUTS:
;
;   DEFAULT - a "default" subcell.  Any elements that are negative are
;             replaced by DEFSUBCELL's notion of the proper margins.
;             This feature is used, for example, by SUBCELLARRAY to
;             make subcells that have special margins on certain sides
;             and default ones on other sides.
;
; OPTIONAL INPUTS:
;   NONE
;
; INPUT KEYWORD PARAMETERS:
;
;   NONE
;
; RETURNS:
;   The new subcell.
;
; PROCEDURE:
;
; EXAMPLE:
;
; SEE ALSO:
;
;   DEFSUBCELL, SUBCELLARRAY
;
; EXTERNAL SUBROUTINES:
;
; MODIFICATION HISTORY:
;   Written, CM, 1997
;
;-
;+
; NAME:
;   DXBREAK
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Sets an IDL breakpoint
;
; CALLING SEQUENCE:
;   DXBREAK, LINE                        ; current procedure (OR)"
;   DXBREAK, 'PROCNAME', LINE            ; named procedure (OR)"
;   DXBREAK, 'path/procname.pro', LINE   ; procedure path (OR)"
;   DXBREAK, PROCNAME, LINE              ; without quotes"
;
; DESCRIPTION: 
;
;   DXBREAK is a convenience routine for setting IDL breakpoints.
;
;   The benefits over the built-in IDL procedure BREAKPOINT are:
;     * fewer characters to type;
;     * full pathname not required, just a procedure name; and
;     * for breakpoints within the current procedure, the file name 
;       is not needed.
;
;   To clear breakpoints, use either DXCLEAR or BREAKPOINT, /CLEAR.
;
; INPUTS:
;
;   LINE - the line number where the breakpoint is to be set.  This
;          value is required.
;
;   PROCNAME - the procedure name in which the breakpoint is to be
;              set.  Note that IDL requires that a procedure be
;              compiled on disk -- console-compiled or .RUN files
;              cannot have breakpoints set.
;
;              The name is one of:
;                * the procedure or function name;
;                * the full path to the procedure or function; OR
;                * an unquoted procedure or function name.
;
;              DXBREAK will search your path to find the correct
;              procedure.  The first file found will be used.
;
;
; KEYWORDS:
;
;   ONCE - if set, then the breakpoint will only occur once.  The same
;          as the ONCE keyword to BREAKPOINT.
;
;   IS_FUNCTION - if set, and there is an ambiguity between whether
;                 PROCNAME is a procedure or a function, then DXBREAK
;                 will assume that it is a function.
;
; EXAMPLE:
;
;   dxbreak, 'myfunc', 50
;
;   Set breakpoint in MYFUNC at line 50.
;
; SEE ALSO:
;
;   BREAKPOINT, DXCLEAR
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;   Addition of NOCATCH keyword for internal testing, 21 Sep 2000, CM
;   Made mostly compatible with IDL v4, 21 Sep 2000, CM
;   Added AFTER keyword, 13 Dec 2000, CM
;   Removed AFTER, use _EXTRA instead, 08 Apr 2001, CM
;
;  $Id: dxbreak.pro,v 1.4 2001/04/08 16:59:55 craigm Exp $
;
;-
; Copyright (C) 2000-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXCLEAR
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Clears an IDL breakpoint
;
; CALLING SEQUENCE:
;   DXCLEAR, INDEX
;
; DESCRIPTION: 
;
;   DXBREAK is a convenience routine for clearing IDL breakpoints.
;   Its primary benefits are that it is symmetric with DXBREAK, and it
;   requires fewer characters to type.
;
; INPUTS:
;
;   INDEX - the breakpoint number, as listed by HELP, /BREAKPOINT.
;
;
; EXAMPLE:
;
;   dxclear, 0
;
;   Clear breakpoint number 0
;
; SEE ALSO:
;
;   BREAKPOINT, DXBREAK
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;
;  $Id: dxclear.pro,v 1.2 2001/02/09 04:57:15 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXCOMMON
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Defines DEBUG_LEVEL common block (INTERNAL)
;
; DESCRIPTION: 
;
;   This code fragment defines the DEBUG_LEVEL common block.  This
;   common is internal to the debugging procedures.
;
;  $Id: dxcommon.pro,v 1.2 2001/02/09 04:57:15 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;
; Define function names just to be sure
;
forward_function routine_names, routine_info

;
; Define DEBUG_LEVEL common block
;
common debug_level, dblevel, dbtraceback

;
; Set common block values 
;
if n_elements(dblevel) EQ 0 then begin
  dblevel = 0L
  dbtraceback = ['']
endif
;+
; NAME:
;   DXDOWN
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Move the debugging focus deeper down the IDL call stack
;
; CALLING SEQUENCE:
;   DXDOWN [ , NLEVELS ]
;
; DESCRIPTION: 
;
;   DXDOWN moves the debugging "focus" deeper down the IDL call stack.
;   By using this procedure and DXUP, one can navigate up and down an
;   existing call stack, and examine and set variables at various
;   levels.
;
;   While IDL always keeps the command line at the deepest call level
;   (i.e., where the breakpoint occurred), DXDOWN and its related
;   debugging procedures maintain a separate notion of which part of
;   the call stack they are examining -- the debugging "focus."
;
;   DXDOWN moves the debugging focus deeper by at least one level, but
;   never beyond the deepest level.
;
; INPUTS:
;
;   NLEVELS - option number of levels to move.  Default (and minimum)
;             value is 1.
;
; EXAMPLE:
;
;   dxdown
;
;   Move the debugging focus down one level.
;
; SEE ALSO:
;
;   DXUP, DXDOWN, DXGET, DXSET
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxdown.pro,v 1.2 2001/02/09 04:57:16 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXFINISH
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Sets an IDL breakpoint to stop upon return of the current procedure
;
; CALLING SEQUENCE:
;   DXFINISH [ , NLEVELS ]
;
; DESCRIPTION: 
;
;   DXFINISH is a convenience routine for setting IDL breakpoints.
;
;   DXFINISH sets a breakpoint so that when the current procedure
;   finishes, execution will stop.  Often when debugging one wants to
;   let the current procedure complete but stop at the next level.
;   DXFINISH does exactly that.
;
;   DXFINISH examines the state of the current IDL call stack,
;   determines at what point the current procedure will return, and
;   sets a breakpoint there.  Note that the procedure in which the
;   breakpoint is set must be compiled and on disk.
;
;   By default the breakpoint is set with the ONCE keyword.
;
; INPUTS:
;
;   NLEVELS - Number of call levels up to set breakpoint.  Default is
;             1.
;
; KEYWORDS:
;
;   ONCE - if set, then the breakpoint will only occur once.  Default
;          value is SET, so ONCE=0 must be passed explicitly to
;          disable this function.
;
; EXAMPLE:
;
;   dxfinish
;
;   Set breakpoint in calling procedure.
;
; SEE ALSO:
;
;   BREAKPOINT, DXBREAK, DXCLEAR
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxfinish.pro,v 1.2 2001/02/09 04:57:16 craigm Exp $
;  
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXGET
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Gets IDL variable from a different IDL call level
;
; CALLING SEQUENCE:
;   RESULT = DXGET('NAME')  ; quoted variable name (OR)
;   RESULT = DXGET(NAME)    ; unquoted variable name
;
; DESCRIPTION: 
;
;   DXGET retrieves a variable value from any point in the IDL call
;   stack.  The DXGET and DXSET routines allow any variable at any
;   level to be examined and changed.
;
;   The call level to be examined is determined by the current
;   debugging "focus."  By default this is the deepest level in the
;   call stack -- where the breakpoint occurred.  However, this level
;   can be changed by using the DXUP and DXDOWN procedures.
;
;   If the variable doesn't exist, then an error message is reported.
;
; INPUTS:
;
;   NAME - the name of the variable, either quoted or unquoted.
;
; KEYWORDS:
;
;   LEVEL - the call level to be examined, if not the current
;           debugging focus.
;
; EXAMPLE:
;
;   value = dxget('a')
;
;   Retrieve the value of the variable A from the debugged call level.
;
; SEE ALSO:
;
;   DXGET, DXSET, DXUP, DXDOWN
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxget.pro,v 1.2 2001/02/09 04:57:16 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXHELP
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Perform HELP equivalent at any point in IDL call stack
;
; CALLING SEQUENCE:
;   DXHELP, X0, X1, ..., [ LEVEL=LEVEL ]
;
; DESCRIPTION: 
;
;   DXHELP performs the equivalent of HELP for the variables at any
;   level in the IDL call stack.
;
;   The call level to be examined is determined by the current
;   debugging "focus."  By default this is the deepest level in the
;   call stack -- where the breakpoint occurred.  However, this level
;   can be changed by using the DXUP and DXDOWN procedures.
;
;   If the ALL keyword is set, then all variables are examined.
;
; INPUTS:
;
;   Xi - variables to be examined, either quoted or unquoted.
;        Non-string expressions are diagnosed, but of course refer to
;        the deepest call level.  If the ALL keyword is set then the
;        Xi parameters are ignored.
;
; KEYWORDS:
;
;   LEVEL - the call level to be examined, if not the current
;           debugging focus.
;
;   ALL - if set, then all variables at the current focus level are
;         examined.
;
;
; EXAMPLE:
;
;   dxhelp
;
;   Print all variables at current debugging focus level
;
; SEE ALSO:
;
;   DXUP, DXDOWN, DXHELP, DXPRINT
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;   Added ALL keyword; changed N_PARAMS() EQ 0 behavior, CM 17 Apr
;     2000
;   DXHELP_VALUE now prints correct string and byte values, CM 23 Apr
;     2000
;   Add support for printing structures with FULL_STRUCT, CM 08 Feb
;     2001
;   Added forward_function for DXHELPFORM, CM 08 Apr 2001
;   Print more info about POINTER type, CM 30 Apr 2001
;   
;
;   $Id: dxhelp.pro,v 1.5 2001/04/30 15:26:53 craigm Exp $
;-
; Copyright (C) 2000-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; INCLUDED FROM HELPFORM.PRO
forward_function dxhelpform
function dxhelpform, name0, value, single=single, shortform=short, $
                     width=width0, tagform=tagform, structure=struct, $
                     _EXTRA=extra

  ;; Names of all the known IDL types, as of IDL 5.2
  typenames = ['UNDEFINED', 'BYTE', 'INT', 'LONG', 'FLOAT', 'DOUBLE', $
               'COMPLEX', 'STRING', 'STRUCT', 'DCOMPLEX', 'POINTER', $
               'OBJREF', 'UINT', 'ULONG', $
               'LONG64', 'ULONG64', 'UNKNOWN']
  blanks = string(replicate(32b,80))
  if n_elements(sz) LT 3 then sz = size(value)
  tp = sz(sz(0)+1) < 16

  if n_elements(name0) EQ 0 then name0 = ''
  name = strtrim(name0(0),2)

  nlen = 15  ;; Length of name
  tlen = 9   ;; Length of type name

  if n_elements(width0) EQ 0 then width0 = 80
  width = floor(width0(0))

  if tp EQ 8 AND keyword_set(struct) then begin
      sz1 = size(value)
      if sz1(sz1(0)+1) NE 8 then goto, NOT_STRUCT
      nt = n_tags(value)
      len = n_tags(value, /length)
      tn = tag_names(value)
      sn = tag_names(value, /structure_name)
      
      if sn EQ '' then sn = '<Anonymous>'

      a = string(sn, nt, len, $
             format='("** Structure ",A0,", ",I0," tags, length=",I0,":")')

      for i = 0, nt-1 do begin
          a = [a, '   '+dxhelpform(tn(i), value(0).(i), /tagform)]
      endfor

      return, a
  endif
  NOT_STRUCT:

  if NOT keyword_set(short) then begin
      ;; Pad the name out, or else put the name on a line by itself
      if strlen(name) GT nlen then begin
          if keyword_set(single) then begin
              a1 = name+' '
          endif else begin
              a0 = name
              a1 = strmid(blanks,0,nlen)+' '
          endelse
      endif else begin
          a1 = strmid(name+blanks,0,nlen)+' '
      endelse
      
      a1 = a1 + strmid(typenames(tp)+blanks,0,tlen)
      if NOT keyword_set(tagform) then $
        a1 = a1 +' = '        
  endif else begin
      a1 = strmid(typenames(tp)+blanks,0,tlen)
  endelse

  ndims = sz(0)
  if ndims GT 0 then begin
      ;; It is an array, compose the dimensions
      dims = sz(1:ndims)  
      v = 'Array['
      for i = 0L, ndims-1 do begin
          v = v + strtrim(dims(i),2)
          if i LT ndims-1 then v = v + ', '
      endfor
      v = v + ']'

      ;; If it is a structure, add the structure name (structures are
      ;; never scalars)
      if NOT keyword_set(short) AND tp EQ 8 then begin
          ;; Protect against empty value
          if n_elements(stname) EQ 0 then begin
              if n_elements(value) GT 0 then v0 = value(0) else v0 = {dummy:0}
              sn = tag_names(v0, /structure_name)
              sn = sn(0)
          endif else begin
              sn = strtrim(stname(0),2)
          endelse
          if sn EQ '' then sn = '<Anonymous>'
          v = '-> '+sn+' ' + v 
      endif
  endif else begin
      ;; It is a scalar

      ;; Protect against empty or vector value
      if n_elements(value) GT 0 then begin
          v0 = value(0) 
      endif else begin
          if tp NE 10 AND tp NE 11 then tp = 0
      endelse

      case tp < 16 of 
          0:  v = '<Undefined>'
          1:  v = string(v0, format='(I4)')
          7:  begin
              w = (width - 35) > 5
              if strlen(v0) GT w then $
                v = "'"+strmid(v0,0,w)+"'..." $
              else $
                v = "'"+v0+"'"
          end
          10: begin
              sz = size(v0)
              if sz(sz(0)+1) EQ 10 then v = string(v0(0), /print) $
              else                      v = '<PtrHeapVar>'
          end
          11: begin
              if n_elements(stname) EQ 0 then begin
                  forward_function obj_class
                  sz = size(v0)
                  if sz(sz(0)+1) EQ 11 then sn = '('+obj_class(v0)+')' $
                  else                      sn = ''
              endif else begin
                  sn = '('+strupcase(strtrim(stname(0),2))+')'
              endelse
              v = '<ObjHeapVar'+sn+'>'
          end
          16: v = ''
          else: v = string(v0)
      endcase
  endelse

  if keyword_set(short) then return, a1 + '('+v+')'

  a1 = a1 + v
  if n_elements(a0) GT 0 then return, [a0, a1] else return, a1
end
; END INCLUDE

pro dxhelp, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, level=level0, all=all, $
            _EXTRA=extra
@dxcommon.pro

  dxlreset
  if n_elements(level0) EQ 0 then level0=dblevel
  level = floor(level0(0))

  ;; Print the current debugging levels
  dxplevel, level=level, current=keyword_set(all)

  ;; Two different behaviors, depending on whether parameters are passed.
  if keyword_set(all) then begin
      
      ;; ALL was set... we extract the names of the variables from the
      ;; procedure itself.
      vars = routine_names(variables=level)
      if n_elements(vars) EQ 1 then $
        if vars(0) EQ '' then return

      for i = 0L, n_elements(vars)-1 do begin
          ;; Retrieve the variable's value, but make sure it is not
          ;; undefined
          name = vars(i)
          val = 0
          if name EQ '' then name = '<Expression>'
          sz = size(routine_names(vars(i), fetch=level))
          dummy = temporary(val)
          if sz(sz(0)+1) NE 0 then val = routine_names(vars(i), fetch=level)
          print, dxhelpform(name, val, _EXTRA=extra), format='(A)'
      endfor
  endif else begin

      ;; ALL was not set, so we examine individual arguments
      if n_params() EQ 0 then return

      thislev = routine_names(/level)
      for i = 0L, n_params()-1 do begin

          ;; First, extract the parameter name using ROUTINE_NAMES magic
          name = ''
          ii = strtrim(i,2)
          cmd = 'name = routine_names(x'+ii+',arg_name=thislev-1)'
          if execute(cmd) NE 1 then goto, NEXT_PARM
          if n_elements(name) LT 1 then goto, NEXT_PARM
          name0 = name(0)
          name = name0
          if name0 EQ '' then begin
              ;; The value might be a quoted string... see if it is!
              cmd = 'val = x'+ii
              if execute(cmd) NE 1 then goto, NEXT_PARM

              sz = size(val)
              if sz(sz(0)+1) EQ 7 then begin
                  ;; It was a string!
                  name0 = val
                  goto, GET_VAL
              endif
              name = '<Expression>'
              val = 0
          endif else begin
              GET_VAL:
              ;; Retrieve the value, again guarding against undefined values
              sz = size(routine_names(name0, fetch=level))
              val = 0
              dummy = temporary(val)
              if sz(sz(0)+1) NE 0 then val = routine_names(name0, fetch=level)
          endelse

          ;; Print it
          print, dxhelpform(name, val, _EXTRA=extra), format='(A)'
          NEXT_PARM:
      endfor
  endelse

end
;+
; NAME:
;   DXLRESET
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Reset the current debugging focus level (INTERNAL)
;
; CALLING SEQUENCE:
;   DXLRESET
;
; DESCRIPTION: 
;
;   DXLRESET resets the current debugging focus level, if it has
;   changed.  This routine is internal to the debugging procedures.
;
; SEE ALSO:
;
;   DXUP, DXDOWN, DXGET, DXSET
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxlreset.pro,v 1.2 2001/02/09 04:57:16 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXPLEVEL
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Print the current call stack (INTERNAL)
;
; CALLING SEQUENCE:
;   DXPLEVEL
;
; DESCRIPTION: 
;
;   DXLRESET prints the current call stack, and highlights the
;   debugging focus level.This routine is internal to the debugging
;   procedures.
;
; SEE ALSO:
;
;   DXUP, DXDOWN, DXGET, DXSET
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxplevel.pro,v 1.2 2001/02/09 04:57:17 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXPRINT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Perform HELP equivalent at any point in IDL call stack
;
; CALLING SEQUENCE:
;   DXPRINT, X0, X1, ... [, LEVEL=LEVEL, FORMAT=FORMAT ]
;
; DESCRIPTION: 
;
;   DXPRINT prints the values of variables from any level in the IDL
;   call stack.
;
;   The call level to be examined is determined by the current
;   debugging "focus."  By default this is the deepest level in the
;   call stack -- where the breakpoint occurred.  However, this level
;   can be changed by using the DXUP and DXDOWN procedures.
;
; INPUTS:
;
;   Xi - variables to be printed, unquoted.  Non-string expressions
;        are printed, but of course refer to the deepest call level.
;
; KEYWORDS:
;
;   LEVEL - the call level to be examined, if not the current
;           debugging focus.
;
;   FORMAT - format string to be applied to data values.
;
;
; EXAMPLE:
;
;   dxprint, a, b
;
;   Print A and B from the current debugging focus level
;
; SEE ALSO:
;
;   DXUP, DXDOWN, DXHELP, DXPRINT
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;   Corrected FORMAT statement, 30 Jun 2001
;
;  $Id: dxprint.pro,v 1.3 2001/06/30 19:56:04 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXPTRACE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Parse the current call stack (INTERNAL)
;
; CALLING SEQUENCE:
;   RESULT = DXPTRACE(STRING)
;
; DESCRIPTION: 
;
;   DXPTRACE is a function which parses the call stack, as returned by
;   HELP, /CALL.  It is internal to the debugging routines.
;
; SEE ALSO:
;
;   DXUP, DXDOWN, DXGET, DXSET
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxptrace.pro,v 1.2 2001/02/09 04:57:17 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXSET
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Sets IDL variable in a different IDL call level
;
; CALLING SEQUENCE:
;   DXSET, 'NAME', VALUE    ; quoted variable name (OR)
;   DXSET,  NAME,  VALUE    ; unquoted variable name
;
; DESCRIPTION: 
;
;   DXSET sets a variable value at any point in the IDL call stack.
;   The DXGET and DXSET routines allow any variable at any level to be
;   examined and changed.
;
;   The call level to be examined is determined by the current
;   debugging "focus."  By default this is the deepest level in the
;   call stack -- where the breakpoint occurred.  However, this level
;   can be changed by using the DXUP and DXDOWN procedures.
;
;   If the variable doesn't exist, then an error message is reported,
;   and the variable is not set.
;
; INPUTS:
;
;   NAME - the name of the variable, either quoted or unquoted.
;
;   VALUE - the new value of the variable.
;
; KEYWORDS:
;
;   LEVEL - the call level to be examined, if not the current
;           debugging focus.
;
; EXAMPLE:
;
;   dxset, 'a', 5
;
;   Set the value of the variable A to 5 in the currently debugged
;   call level.
;
; SEE ALSO:
;
;   DXGET, DXSET, DXUP, DXDOWN
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxset.pro,v 1.2 2001/02/09 04:57:18 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   DXUP
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Move the debugging focus higher up the IDL call stack
;
; CALLING SEQUENCE:
;   DXUP [ , NLEVELS ]
;
; DESCRIPTION: 
;
;   DXUP moves the debugging "focus" higher up the IDL call stack.  By
;   using this procedure and DXDOWN, one can navigate up and down an
;   existing call stack, and examine and set variables at various
;   levels.
;
;   While IDL always keeps the command line at the deepest call level
;   (i.e., where the breakpoint occurred), DXUP and its related
;   debugging procedures maintain a separate notion of which part of
;   the call stack they are examining -- the debugging "focus."
;
;   DXUP moves the debugging focus higher by at least one level, but
;   never beyond the "root" $MAIN$ level.
;
; INPUTS:
;
;   NLEVELS - option number of levels to move.  Default (and minimum)
;             value is 1.
;
; EXAMPLE:
;
;   dxup
;
;   Move the debugging focus up one level.
;
; SEE ALSO:
;
;   DXUP, DXDOWN, DXGET, DXSET
;
; MODIFICATION HISTORY:
;   Written, 15 Apr 2000
;
;  $Id: dxup.pro,v 1.2 2001/02/09 04:57:18 craigm Exp $
;
;-
; Copyright (C) 2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   EOPDATA
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Read and interpolate tabulated earth orientation parameters
;
; MAJOR TOPICS:
;   Geometry
;
; CALLING SEQUENCE:
;   EOPDATA, JDUTC, PMX, PMY, UT1_UTC, DPSI, DEPS, $
;        /RESET, FILENAME=, ANGUNITS=, TBASE=
;
; DESCRIPTION:
;
;  The procedure EOPDATA reads, interpolates and returns Earth
;  orientation parameters used for precision earth-base astronomy
;  applications.
;
;  ** NOTE: The user is responsible for downloading and maintaining an
;  up-to-date file of earth orientation parameters from the
;  International Earth Rotation Service.  See below. **
;
;  This interface is somewhat provisional.  See OPEN QUESTIONS below.
;
;  The values returned are described below.  These descriptions are
;  taken from the Explanatory Supplement to IERS Bulletins A and B.
;
;    * PMX and PMY, the coordinates of the Celestial Ephemeris Pole
;      (CEP) relative to the earth-fixed International Reference Pole
;      (IRP).  The x-axis is in the direction of the IERS Reference
;      Meridian (IRM), the y-axis is in the direction 90 degrees West
;      longitude.  The time series of PMX and PMY is referred to as
;      "polar motion."
;
;      These are the coordinates of the earth rotation pole, as seen
;      in an *earth-fixed* coordinate system.  A station whose
;      coordinates are given in earth-fixed coordinates referred to
;      the ITRS can be transformed to the earth-fixed coordinates
;      referred to the true rotation pole of date using the following
;      matrix transformation:
;            
;             R_TRUE = RX(PMY) ## RY(PMX) ## R_ITRS
;
;      where the matrices RX and RY are defined below.
;
;    * UT1, the the rotation angle about the pole. It is related to
;      the Greenwich mean sidereal time (GMST) by a conventional
;      relationship (Aoki et al., 1982).  It gives access to the
;      direction of the International Reference Meridian IRM in the
;      ICRS, reckoned around the CEP axis. It is expressed as the
;      difference UT1-UTC.  Thus, the value of UT1 is computed as:
;
;          UT1 = UT1_UTC + UTC
;
;      where UTC is the UTC time, expressed in seconds.
;
;    * DPSI and DEPS are the offsets in longitude and obliquity of the
;      celestial pole with respect to its direction defined using the
;      conventional IAU precession/nutation theory.  An a priori
;      correction model is available in the IERS Conventions (1996),
;      (McCarthy, 1996).  The expressions to compute the nutation
;      angles are:
;
;          DEPS_TRUE = DEPS_1980 + DEPS    ;; Nutation in obliquity
;          DPSI_TRUE = DPSI_1980 + DPSI    ;; Nutation in longitude
;
;      where DPSI_1980 and DEPS_1980 are the nutation values
;      determined from the IAU 1980 Nutation Theory; and DPSI_TRUE and
;      DEPS_TRUE are the nutations to be used as arguments to further
;      precession and nutation computations.
;
;  For requested times which are between tabular values, a linear
;  interpolation is performed.  This is not exactly the correct
;  procedure, and can result in errors of +/- 0.1 mas in the earth
;  polar motion and 1 usec in UT1 (see McCarthy & Gambis 1997).
;
;
; DATA FILES and MAINTENANCE
;
;   The user is responsible for downloading and maintaining the earth
;   orientation parameters file as supplied by the IERS.  The format
;   of the files is the "Final" EOP data ASCII format.  They can be
;   downloaded here:
;
;      ftp://maia.usno.navy.mil/ser7/finals.all   ;; from May 1976-present
;      ftp://maia.usno.navy.mil/ser7/finals.data  ;; from Jan 1992-present
;   
;   The user must place this file in a known location, and in *at
;   least the first call*, this filename must be passed using the
;   FILENAME keyword.
;
;   EOPDATA will load the data once on the first call, and keep a
;   cached copy for subsequent calls.  On a daily basis the file will
;   be reloaded in case the quantities have been updated from the
;   server.  A reload of data can be forced using the RESET keyword.
;
; ROTATION MATRICES
;
;   The rotation matrices RX(T) and RY(T) mentioned above in relation
;   to polar motion are:
;
;      RX(T) =EQ= [[1,0,0], [0,cos(T),sin(T)], [0,-sin(T),cos(T)]]
;      RY(T) =EQ= [[cos(T),0,-sin(T)], [0,1,0], [sin(T),0,cos(T)]]
;      RZ(T) =EQ= [[cos(T),sin(T),0], [-sin(T),cos(T),0], [0,0,1]]
;
;   and are meant to be applied to a vector R as, RX(T) ## R.
;
;
; OPEN QUESTIONS
;
;   How will the transition to a new IERS EOP series be accomplished?
;   Using a keyword?
;
;   Should there be a quality flag?  The EOP file contains a
;   "predicted" flag, and also there are rows which contain no value
;   at all.  These should probably be flagged somehow.
;
;
; INPUTS:
;
;   JDUTC - a vector or scalar, the UTC time for which earth
;           orientation parameters are requested, expressed in Julian
;           Days.  The value of the keyword TBASE is added to this
;           quantity to arrive at the actual Julian date.
;
; OUTPUTS:
;
;   PMX, PMY - the earth-fixed angular coordinates of the celestial
;              ephemeris pole, measured in ANGUNITS units.
;
;   UT1_UTC - the value of UT1 - UTC, expressed in seconds.
;
;   DPSI, DEPS - the corrections to the IAU 1980 theory of Nutation,
;                for nutation in longitude and obliquity, expressed in
;                ANGUNITS units.
;
; KEYWORD PARAMETERS:
;
;   FILENAME - scalar string, on the first call, the name of the file
;              from which earth orientation parameters will be read.
;              Default value: (none)
;
;   TBASE - a fixed epoch time (Julian days) to be added to each value
;           of JDUTC.  Since subtraction of large numbers occurs with
;           TBASE first, the greatest precision is achieved when TBASE
;           is expressed as a nearby julian epoch, JDUTC is expressed
;           as a small offset from the fixed epoch.
;           Default: 0
;
;   ANGUNITS - scalar string, output units of angular parameters.
;              Possible values are 'ARCSEC' or 'RADIAN'.
;              Default value: 'RADIAN'
;
;   RESET - if set, forces EOP file to be re-read.
;
;
; EXAMPLE:
;
;
; SEE ALSO:
;
;   HPRNUTANG, TAI_UTC (Markwardt Library)
;   PRECESS, PREMAT, JPRECESS, BPRECESS (IDL Astronomy Library)
;
;
; REFERENCES:
;
;   Aoki, S., Guinot, B., Kaplan, G.H., Kinoshita, H., McCarthy, D.D.,
;     Seidelmann, P.K., 1982: Astron. Astrophys., 105, 359-361.
;
;   McCarthy, D. D. (ed.) 1996: IERS Conventions, IERS T.N. 21.
;     http://maia.usno.navy.mil/conventions.html
;
;   McCarthy, D. \& Gambis, D. 1997, "Interpolating the IERS Earth
;     Orientation Data," IERS Gazette No. 13, 
;     http://maia.usno.navy.mil/iers-gaz13
;     Instructions for high precision EOP data interpolation, not done
;     in this procedure.
;
;   Ray, J. & Gambis, D. 2001, "Explanatory Supplement to IERS
;     Bulletins A and B,"
;     http://hpiers.obspm.fr/iers/bul/bulb/explanatory.html
;
;     Explains meanings of earth orientation parameters used and
;     returned by this procedure.
;
;   Definition of Final EOP data format
;     ftp://maia.usno.navy.mil/ser7/readme.finals
;
; MODIFICATION HISTORY:
;   Written, 30 Jan 2002, CM
;   Documented, 14 Feb 2002, CM
;   Add default message, 01 Mar 2002, CM
;   More robust handling of input file, 10 Mar 2002, CM
;
;  $Id: eopdata.pro,v 1.6 2009/01/02 17:45:13 craigm Exp $
;
;-
; Copyright (C) 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FILE_COMPILE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20771
;   Craig.Markwardt@nasa.gov
;
; PURPOSE:
;   Compile an arbitrary procedure
;
; CALLING SEQUENCE:
;   FILE_COMPILE, pathname, ERROR=error, ERRMSG=errmsg
;
; DESCRIPTION: 
;
;   FILE_COMPILE compiles a file containing an IDL procedure or
;   function.  After compilation the user may call the procedure or
;   function.
;
;   If compilation is successful, then ERROR is set to 0.  If the
;   compilation fails, then, ERROR is set to a non-zero error code,
;   and ERRMSG is set to a descriptive error message.
;
; INPUTS:
;
;   PATHNAME - scalar string, path name of file containing IDL
;              procedure or function.  PATHNAME must end in '.pro'.
;              The directory containing the file must be readable and
;              it must be possible to change to that directory as a
;              working directory using CD.
;
; KEYWORDS:
;
;   ERROR - upon return, a scalar integer giving status of
;           compilation, either 0 for success or non-zero for failure.
;
;   ERRMSG - upon return, a scalar string giving a descriptive error
;            message.
;
;   PRO_NAME - upon return, the name of the procedure, with path name
;              and '.pro' suffix removed.
;
; SEE ALSO:
;
;   RESOLVE_ROUTINE
;
; MODIFICATION HISTORY:
;   Documented, CM, Jun 2009
;   Small documentation changes, CM, 2012-10-09
;
;  $Id: file_compile.pro,v 1.2 2012/10/17 23:53:58 cmarkwar Exp $
;
;-
; Copyright (C) 2009, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FLORMAT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   Craig.Markwardt@nasa.gov
;
; PURPOSE:
;   Format a string with named format variables
;
; CALLING SEQUENCE:
;   RESULT = FLORMAT(FORMAT, [ struct ], [x=x, y=y, ...], [_EXTRA=struct])
;
; DESCRIPTION: 
;
;  The function FLORMAT is used to easily insert a set of named
;  parameters into a string using simple format codes.  The key point
;  is that format strings use *named* parameters instead of the
;  position in the string.
;
;  FLORMAT makes it easy to make maintainable and understandable
;  format codes.  FLORMAT is a convenience routine, which will be most
;  suitable for formatting tabular output, but can be used for any
;  complicated string formatting job where the positional parameters
;  of STRING() become hard to manage.  Users of Python will recognize
;  FLORMAT as implementing "string interpolation."
;
;  The user passes a format string similar to the IDL printf-style
;  format string (i.e. using modified "%" notation), and a set of
;  named fields either by passing a structure, keywords, or both.  The
;  output strings are composed by inserting the named fields into the
;  format string with any requested formatting.
;
;  The function FLORMAT is equivalent to the STRING(...,FORMAT=fmt)
;  method of formatting a string, where the format string is allowed
;  to have the name of the variable. 
;
;  Let us consider an example of formatting a time with hours, minutes
;  and seconds into a string as HH:MM:SS.  One could use FLORMAT()
;  like this,
;
;     result = flormat('%(hour)02d:%(min)02d:%(sec)02d', $
;                      hour=hour, min=min, sec=sec)
;
;  The variables HOUR, MIN and SEC are allowed to be scalars or
;  vectors.  The key point here is that the format string contains the
;  *named* keyword variables (or structure entries).  Unlike STRING(),
;  the actual variables can be passed in any order, since the format
;  string itself describes in what order the values will be assembled.
;  This is similar to string interpolation in Python.
;
;  The same variable can appear multiple times in the format string,
;  but the user only need to specify that variable once.  For example,
;
;     result = flormat('<A="%(href)s">Download %(href)s</A>', $
;                      href='filename.txt')
;
;  Note that HREF appears twice in the format string.
;
; INPUT VARIABLES:
;
;  FLORMAT() allows you to pass in the values as named keywords as
;  shown above, where the keyword values are arrays, or by passing in
;  an array of structures.  A similar example to the one above is,
;  
;     S = replicate({hour: 0, min: 0, sec: 0}, 100)
;     ;   ... fill the structure S with 100 time values ...
;     result = flormat('%(hour)02d:%(min)02d:%(sec)02d', s)
;  
;  In this case S is an array of structures, and the result will be an
;  array of strings with the same number of elements as S.
;
;  Compare this with standard IDL where a FOR-loop is required, no
;  repetition is permitted, and it is difficult to see which format
;  code corresponds to which variable.  For example,
;   
;     for i = 0, n_elements(hour)-1 do begin
;       result(i) = string(hour(i), min(i), sec(i), $
;                          format='(%"%02d:%02d:%02d")')
;
;   The input structure STRUCT may be an array of structures or a
;   structure of arrays.  It is also possible pass *both* a structure
;   STRUCT and keywords.  The important thing is that the each keyword
;   and each STRUCT.FIELD must evaluate to the same number of
;   elements.  If they don't, then the smallest number of elements is
;   used.
;
; PRINTF-STYLE FORMAT CODES
;
;  FLORMAT() uses format codes in either C printf-style format codes
;  (the default), or a new "$" shell-style syntax if /SHELL_STYLE$ is
;  set.
;
;  FLORMAT() assumes that by default the C printf-style format codes
;  are passed.  FLORMAT() uses a slightly short-hand notation for
;  print-style format codes which saves some space and is more
;  flexible.
;
;  Standard printf-style format codes are of the form,
;      FORMAT='(%"...format here...")'     ;; Standard IDL
;  The FLORMAT printf-style format codes simply dispense with the
;  redundant parentheses and percent symbol,
;      FORMAT='...format here...'          ;; FLORMAT notation
;  This notation improves the readability of the format string, since
;  only the actual format string needs to be present.  Also, this
;  notation does not embed one set of quotation marks within another,
;  as the standard IDL notation does, so format strings with quotation
;  marks will be easier to compose.
;
;  Standard IDL format codes look like this,
;        %s - string
;        %d - integer
;        %04d - integer zero-padded to 4 spaces, etc
;
;  The new FLORMAT format strings look like this,
;
;        %(name)s - string based on variable named NAME
;        %(value)d - integer based on variable named VALUE
;        %(index)04d - integer based on variable named INDEX, 
;                      zero-padded to 4 spaces
;
;  As you can see, the only difference is the addition of the variable
;  name in parenthesis.  These names are looked up in the input 
;  keywords and/or structure passed to FLORMAT().
;
; SHELL-STYLE FORMAT CODES
;
;  Shell style "$" is a convenience notation when strict formatting is
;  less important.  Shell-style "$" format strings will be signaled by
;  setting the SHELL_STYLE$ keyword.  Note the trailing dollar-sign
;  '$'.  The format coes will look like this,
;
;       $name   - variable named NAME will be placed here
;       $value  - variable named VALUE will be placed here, etc.
;
;  This is exactly how Unix shell string interpolation works.
;  Variables are substituted into place using their "natural" format
;  code, based on the variable type.
;
;     result = flormat('<A=\"$href\">Download $href</A>', /shell_style$, $
;                      href='filename.txt')
;
;  Note that quotation marks still need to be escaped as \", just the
;  same as calling STRING() or PRINT with a %-style format string.
;
; CAVEATS:
;
;  FLORMAT() is a convenience routine meant mostly to improve the
;  readability and maintainability of format codes. FLORMAT() is not
;  meant for high performance applications.  It spends time parsing
;  the input format string.  It also spends memory building up a
;  temporary output structure.  However, for most applications such as
;  constructing tables of up to thousands of entries, FLORMAT() should
;  be perfectly adequate.
;
;  The name "FLORMAT" is a play on the words "floor-mat" and "format."
;  The "L" in FLORMAT can be thought of standing for "long-form" IDL
;  format codes.
;
; PARAMETERS:
;
;   FORMAT - format string used to 
;
;   STRUCT - input structure containing named entries.  This should
;            either be an array of structures, with each field
;            containing a scalar; or, a structure where each field
;            contains an array with the same number of elements.
;
; RETURNS:
;
;   The resulting formatted strings.  The return value will be an
;   array of strings containing the same number of elements as passed
;   as input.
;
; KEYWORD PARAMETERS:
;
;   SHELL_STYLE$ - if set, then the format string is a shell-style
;                  string.
;
;   All named keywords are available to be used as named formats in
;   your format code.  Values may be either scalar, or vector.
;   Vectors dimensions must match the dimensions of STRUCT (if
;   STRUCT is passed).
;
; EXAMPLE:
;
;  
;  ; Additional examples appear above.
;
; SEE ALSO:
;
;   STRING, Format codes, C print-style format codes
;
; MODIFICATION HISTORY:
;   Written, CM, 14 Sep 2009
;   Finalized and documented, CM, 08 Dec 2011
;
;  $Id: flormat.pro,v 1.9 2013/03/16 23:29:40 cmarkwar Exp $
;
;-
; Copyright (C) 2011, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;;  ;; Replace '"' by '\"' (poor man's REPSTR)
;;  ofmts = strsplit(ofmt, '"', /preserve_null, /extract)
;;  nquote = n_elements(ofmts)-1
;;  if nquote GT 0 then begin
;;      ofmts[0:nquote-1] = ofmts[0:nquote-1] + '\"'
;;      ofmt = strjoin(ofmts)
;;  endif

  ofmt1 = '(%"'+ofmt+'")'
  return, string(outs, format=ofmt1, $
                 am_pm=am_pm, days_of_week=days_of_week, months=months)

end
; COMMON FXFILTER
;  * Defines mapping between normal IDL I/O and FILTER I/O
;  FILTERFLAG - for each LUN, = 1*FILTERED + 2*PIPE + 4*DISK_STORE
;                               FILTERED - use FXG library? 1=yes 0=no
;                               PIPE     - is a pipe?       1=yes 0=no
;                               DISK_STORE - backing store on disk=1 mem=0
;  SEEK_CMD   - for each LUN, procedure to execute when performing POINT_LUN
;  READ_CMD   - for each LUN, procedure to execute when performing READU
;  WRITE_CMD  - for each LUN, procedure to execute when performing WRITEU     
;  CLOSE_CMD  - for each LUN, procedure to execute when performing CLOSE
;
; MODIFICATION HISTORY
;   2000-12-28 Initial revision, CM
;   2007-09-01 Document new values of FILTERFLAG; add MEMCACHE_MAX, add
;     third field to filter suffixes for flags, CM
;   2009-02-12 Interoperability with Windows (scratch dir); handle
;     multiple flags; allow user to set flags, CM
;   2012-04-17 Promote file position pointers to LONG64, CM
; 
;  $Id: fxfilter.pro,v 1.5 2012/04/17 18:31:38 cmarkwar Exp $
;-
; Copyright (C) 1999-2000, 2007, 2009, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; COMMON FXFILTER_CONFIG
;  * Defines general configuration of the filter package
;  * Can be manipulated by FXMAKEMAP
;  SCRATCH_DIR - directory where cache files are stored   (string)
;  BUFFER_MAX  - maximum buffer size (in bytes) of a pipe read (long)
;  BUFFER_GRAN - buffer size granularity (in bytes), should be a large
;                power of 2, probably >= 512 (long)
;  RM_COMMAND  - unix command to use to remove a file (string)
;  CACHE_MAX   - maximum in-memory cache of a filtered file
;
        COMMON FXFILTER_CONFIG, SCRATCH_DIR, BUFFER_MAX, BUFFER_GRAN, $
          RM_COMMAND, MEMCACHE_MAX
        IF N_ELEMENTS(SCRATCH_DIR) EQ 0 THEN BEGIN
            SCRATCH_DIR = GETENV('IDL_TMPDIR')
            BUFFER_GRAN = 4096L
            BUFFER_MAX  = 8L*BUFFER_GRAN
            RM_COMMAND  = '/bin/rm'
            MEMCACHE_MAX   = 10L*1024L*1024LL
        ENDIF

; COMMON FXFILTER_FILTERS
;  * Defines mapping between suffixes and commands used to read them.
;  * Can be manipulated by FXMAKEMAP
;  FILTERS - an array of pairs.  The first of the pair gives the 
;            filename suffix to be mapped (without leading '.'), and
;            the second of the pair gives command to be executed when
;            the suffix is encountered.  The command should be in the
;            form of an IDL format statement which transfers the
;            filename into the command.
;
        COMMON FXFILTER_FILTERS, FILTERS
        IF N_ELEMENTS(FILTERS) EQ 0 THEN BEGIN
            ;            SUFF     FORMAT_COMMAND     FLAGS
            FILTERS = [ $
                        [ 'gz', '("gzip -dc ",A0)', 'COMPRESS' ], $
                        [ 'Z',  '("zcat ",A0)',     ''         ]  $
                      ]
        ENDIF
;+
; NAME:
;   FXGCLOSE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Closes a generic resource
;
; MAJOR TOPICS:
;   File I/O, Pipes, URLs, FITS
;
; CALLING SEQUENCE:
;   FXGCLOSE, UNIT
;
; DESCRIPTION:
;
;   FXGCLOSE closes a generic resource originally opened by FXGOPEN.
;   All associated system resources are freed.
;
;   You must use the specialized 'FXG' style functions to read, write
;   and seek on file units opened with FXGOPEN:
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; INPUTS:
;
;   UNIT - the unit number of the currently open resource.  The unit
;          must have been previously opened by FXGOPEN.
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 02 Oct 1999, CM
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxgclose.pro,v 1.3 2007/09/01 23:03:23 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXGFILTERED
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Determine if a unit has been opened by FXGOPEN.
;
; MAJOR TOPICS:
;   File I/O, Pipes, URLs, FITS
;
; CALLING SEQUENCE:
;   Q = FXGFILTERED(UNIT)
;
; DESCRIPTION:
;
;   FXGFILTERED is a function which determines whether a UNIT has been
;   opened by FXGOPEN and requires special handling.
;
;   In principle, only 'FXG' procedures should be used to access file
;   units returned by FXGOPEN.  However, if the unit turns out to be a
;   normal file then special treatment is not required.  User programs
;   can use the FXGFILTERED function to find out this information.
;
;   If FXGFILTERED returns 0, then normal file-access procedures (such
;   as READU, WRITEU, CLOSE, and POINT_LUN) can be used.  Otherwise,
;   the 'FXG' routines must be used.
;
; INPUTS:
;
;   UNIT - Any file LUN.
;
; RETURNS:
;   0 - resource is a normal file.
;   1 - resource is not a normal file.
;
; EXAMPLE:
;
;  if fxgfiltered(unit) EQ 0 then begin  
;    ;; If zero then can use standard IDL routines
;    point_lun, unit, position
;    readu, unit, buffer
;    close, unit
;  endif
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 02 Oct 1999, CM
;   Changed copyright notice, 21 Sep 2000, CM
;
; TODO:
;   * Add more protocols
;   * Make more windows friendly
;
;  $Id: fxgfiltered.pro,v 1.3 2007/09/01 23:03:23 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXGOPEN
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Open generic resource as a seekable file.
;
; MAJOR TOPICS:
;   File I/O, Pipes, URLs, FITS
;
; CALLING SEQUENCE:
;   FXGOPEN, UNIT, RESOURCE, ACCESS=ACCESS, ERRMSG=ERRMSG
;
; DESCRIPTION:
;
;   FXGOPEN opens a generic "resource" for reading or writing.  A
;   "resource" can be a file or a Unix pipe, or a standard network
;   URL for the http, https, or ftp protocols.  Networked URLs are
;   handled using the Unix command-line program called 'curl'.
;
;   Readable resources are fully random access.  You are permitted to
;   perform seek operations on both files and streams such as Unix
;   pipes.  In the case of a stream, the stream is read upon demand
;   and saved to an on-disk cache.
;
;   FXGOPEN also automatically recognizes some standard Unix file
;   extensions and operates on them.  For example, files ending with
;   '.gz' are recognized as being compressed with gzip, and are passed
;   through gzcat to uncompress them.  You can display existing
;   filename extension mappings and add new ones using the FXMAKEMAP
;   procedure.  This feature also worked with files retrieved over the
;   network, as long as the processing command declared with FXMAKEMAP
;   is able to accept '-' to indicate the data is supplied via
;   standard input.
;
;   The UNIT number is allocated using GET_LUN; however, the internal
;   implementation may allocate more LUNs.  Therefore you must use
;   FXGCLOSE to close the LUN and be sure that all resources are
;   deallocated.
;
;   You must use the specialized 'FXG' style functions to read, write
;   and seek on the resulting unit number:
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; INPUTS:
;
;   UNIT - FXGOPEN will return a LUN in this variable.  It should be
;          subsequently read and written with FXGREAD, FXGWRITE, and
;          closed with FXGCLOSE.
;
;   RESOURCE - a string, describing the resource to be opened.
;              FXGOPEN will automatically determine how to open it
;              according to:
;
;              * If a filename the suffix may be mapped according to
;              FXMAKEMAP.  In that case the appropriate pipe command
;              is opened as a Unix pipe with FXPOPENR.
;
;              * If a string beginning with "|" then the remaining
;              part of the string is interpretted as a Unix pipe
;              command, to be opened with FXPOPENR.
;
;              * If a URL (uniform resource locator), then it is
;              accessed.  Currently supported protocols are:
;
;                file - a local file
;                http - a file served by a web (HTTP) server
;                ftp - a file served an FTP server
;
;              I would like to add some sort of in-memory files,
;              probably with a "mem" protocol.
;
;
; KEYWORD PARAMETERS:
;
;   ACCESS - a string, set to the access privileges of the resource.
;            Possible values are:
; 
;              'R'  - read-only
;              'W'  - write/create
;              'RW' - write/update
;
;            Not all protocols support writing (for example, none of
;            the "pipe" or network protocols supports writing).
;            DEFAULT: 'R'
;
;   ERRMSG - If a named variable is passed with this keyword, an error
;            message is returned: the empty string indicates success;
;            a non-empty string indicates failure.  If a named
;            variable is not passed, and the ERROR keyword is not
;            used, then execution is stopped upon an error.
;
;   ERROR - If a named variable is passed with this keyword, the error
;           status is returned: a zero indicates success; non-zero
;           indicates failure.  If a named variable is not passed, and
;           the ERRMSG keyword is not used, then execution is stopped
;           upon an error.
;
;   SUFFIX - Force a particular file type by specifying the suffix.
;            Default is to extract the suffix from the file name
;            itself.
;
; EXAMPLE:
;
;   fxgopen, unit, 'myfile.gz', errmsg=errmsg
;   if errmsg NE '' then do_error_message
;   bb = bytarr(1000)  ;; Read 1000 bytes
;   fxgread, unit, bb
;   fxgclose, unit
;
;   This example opens the file myfile.gz using FXGOPEN.  It is
;   automatically gunzip'ed on demand as the request for a 1000-byte
;   read is made.
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 02 Oct 1999, CM
;   Added correct ERROR keyword behavior, 04 Oct 1999, CM
;   Changed copyright notice, 21 Sep 2000, CM
;   Modified to use ARG_PRESENT for ERRMSG and ERROR, 21 Sep 2000, CM
;   Added SUFFIX keyword, 31 Oct 2000, CM
;   Added the HTTP and FTP protocols using curl, 22 Oct 2006, CM
;
; TODO:
;   * Make more windows friendly
;
;  $Id: fxgopen.pro,v 1.5 2009/02/12 02:32:50 craigm Exp $
;
;-
; Copyright (C) 1999-2000,2006 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Utility routine: open a network resource using the 'curl' command
pro fxgopen_curl, unit, resource, suffix, errmsg=errmsg, error=error, _EXTRA=extra
  ;; The curl command automatically redirects to stdout
  cmd = string(resource(0), format='("curl -s ''",A0,"''")')
@fxfilter
  wh = where(suffix EQ filters(0,*), ct)
  ;; Handle the case where the remote file is gzipped, compressed, etc
  ;; XXX: this assumes that the command can take '-' to mean 'stdin'
  if ct GT 0 then cmd = cmd + ' | '+string('-',format=filters(1,wh(0)))
  fxpopenr, unit, cmd, errmsg=errmsg, error=error, _EXTRA=extra
  return
end


PRO FXGOPEN, UNIT, RESOURCE, ACCESS=ACCESS0, errmsg=errmsg, $
             ERROR=error, SUFFIX=suffix0, _EXTRA=extra

  on_error, 2
  error = -1
  errmsg = ''

  ;; Default the parameters
  IF N_ELEMENTS(ACCESS0) EQ 0 THEN ACCESS0='R'
  ACCESS=STRUPCASE(ACCESS0)
  IF ACCESS NE 'R' AND ACCESS NE 'W' AND ACCESS NE 'RW' THEN begin
      MESSAGE = 'ERROR: ACCESS must be R, W, or RW.'
      goto, ERR_RETURN
  endif

  ;; Check that the resource is at least a string.
  sz = size(resource)
  if sz(sz(0)+1) NE 7 then begin
      message = 'ERROR: RESOURCE must be a string.'
      goto, ERR_RETURN
  endif

  ;; Separate the protocol component of a URL
  len = strlen(resource)
  i = 0L
  while i LT len AND strmid(resource, i, 1) NE ':' $
    AND strmid(resource, i, 1) NE '/' do i = i + 1
  if i EQ len OR (i LT len AND strmid(resource, i, 1) EQ '/') then begin
      protocol = 'file'
      location = resource
  endif else begin
      if i EQ 0 OR i EQ len-1 then begin
          message = 'ERROR: incorrect resource name format'
          goto, ERR_RETURN
      endif
      protocol = strmid(resource, 0, i)
      location = strmid(resource, i+1, strlen(resource)-i-1)
  endelse
  
  ;; An ode to DOS: single-letter protocols are probably disk drives
  if strlen(protocol) EQ 1 then begin
      protocol = 'file'
      location = resource
  endif

  ;; Separate the server component
  len = strlen(location)
  i = 0L
  while i LT len AND strmid(location, i, 1) EQ '/' do i = i + 1
  if i EQ 0 OR i EQ 1 then begin ;; No slash, or a single slash -- a local file

      if i EQ len then begin
          message = 'ERROR: incorrect resource name format'
          goto, ERR_RETURN
      endif
      server = ''
      path   = location
  endif else if i EQ 3 then begin ;; Three slashes -- a local file
      server = ''
      path = strmid(location, 2, len-2)
  endif else if i GT 3 then begin ;; Too many slashes
      message = 'ERROR: incorrect resource name format'
      goto, ERR_RETURN
  endif else begin               ;; Format proto://server[/path]
      path = strmid(location, 2, len-2)
      slash = strpos(path, '/')
      if slash EQ -1 then begin  ;; No path
          server = path
          path   = ''
      endif else begin           ;; Server and path
          server = strmid(path, 0, slash)
          path   = strmid(path, slash, strlen(path)-slash)
      endelse
  endelse

  ;; Determine the suffix of the path
  components = str_sep(path, '.')
  len = n_elements(components)
  if len GT 1 then suffix = components(len-1) else suffix = ''
  if n_elements(suffix0) GT 0 then $
    suffix = strtrim(suffix0(0),2)

  ;; Find out if this is a pipe
  if strmid(path, 0, 1) EQ '|' then begin
      if access NE 'R' then begin
          message = 'ERROR: pipes may only be opened with READ access.'
          goto, ERR_RETURN
      endif
      fxpopenr, unit, path, errmsg=errmsg, error=error, _EXTRA=extra
      return
  endif

@fxfilter
  case strlowcase(protocol) of

      ;; FILE access is the only supported protocol currently.
      'file': begin
          wh = where(suffix EQ filters(0,*), ct)
          if ct GT 0 then begin  ;; A filtered file must spawn a pipe

              ;; This file suffix is associated with a PIPE
              if access NE 'R' then begin
                  message = 'ERROR: pipes may only be opened with READ access.'
                  goto, ERR_RETURN
              endif

              ;; Check that the file itself is read-openable.
              openr, unit, path, /get_lun, error=error
              if error NE 0 then goto, OPEN_ERROR
              free_lun, unit

              ;; If it is, then open a pipe on it.
              fmt   = filters(1,wh(0))
              flags = filters(2,wh(0))
              flags = strtrim(strcompress(strupcase(flags)),2)
              compress = 0
              if flags EQ '' then begin
                  cmd = string(path, format=fmt)
              endif else begin
                  case 1 of
                      (strpos(flags,'COMPRESS') GE 0): compress = 1
                  endcase

                  cmd = path
              endelse

              fxpopenr, unit, cmd, compress=compress, $
                errmsg=errmsg, error=error, _EXTRA=extra
              return
          endif else begin

              ;; General file access is achieved through trusty
              ;; OPEN[RWU]

              case access of
                  'R':  openr, unit, path, /block, /get_lun, error=error
                  'W':  openw, unit, path, /block, /get_lun, error=error
                  'RW': openu, unit, path, /block, /get_lun, error=error
              end
              if error NE 0 then begin
                  OPEN_ERROR:
                  ;; Deal with the error condition
                  message = 'ERROR: could not open file "'+path+'"'
                  goto, ERR_RETURN
              endif

              ;; Make sure the FXFILTER entry is zeroed.  We don't
              ;; want trouble!
              filterflag(unit) = 0
              seek_cmd(unit)   = ''
              read_cmd(unit)   = ''
              write_cmd(unit)  = ''
              close_cmd(unit)  = ''
              return
          endelse
      end
      'http':  fxgopen_curl, unit, resource, suffix, errmsg=errmsg, error=error, _EXTRA=extra
      'https': fxgopen_curl, unit, resource, suffix, errmsg=errmsg, error=error, _EXTRA=extra
      'ftp':   fxgopen_curl, unit, resource, suffix, errmsg=errmsg, error=error, _EXTRA=extra
      else: begin

          ;; Sorry... we need more protocols here, but probably with
          ;; an external program such as CURL
          message = 'ERROR: protocol "'+protocol+'" is not supported'
          goto, ERR_RETURN
      end
  endcase

  return

  ERR_RETURN:
  forward_function arg_present  ;; For IDL versions before 5

  if arg_present(errmsg) OR arg_present(error) then begin
      errmsg = message
      return
  endif

  if double(!version.release) LT 5 then begin
      if n_elements(errmsg) NE 0 then begin
          errmsg = message
          return
      endif
  endif
  message, message
end


  
;+
; NAME:
;   FXGREAD
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Perform an unformatted read on a generic resource.
;
; MAJOR TOPICS:
;   File I/O, Pipes, URLs, FITS
;
; CALLING SEQUENCE:
;   FXGREAD, UNIT, BUFFER, TRANSFER_COUNT=TC
;
; DESCRIPTION:
;
;   FXGREAD performs an unformatted read on the unit UNIT.  The UNIT
;   must have previously been opened by FXGOPEN.
;
;   Currently only unformatted reads are permitted because the precise
;   number of bytes to read must be known ahead of time.
;
;   In other respects, this procedure is similar to the READU built-in
;   IDL procedure.
;
;   You must use the specialized 'FXG' style functions to read, write
;   and seek on file units opened with FXGOPEN:
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; INPUTS:
;
;   UNIT - the unit number to operate on.  The unit must have been
;          previously opened by FXGOPEN.
;
;   BUFFER - an array of the desired type and size is passed upon
;            input to FXGREAD.  Only basic types are permitted.  Upon
;            output, the array will have been filled with data from
;            the resource.  The full extent of the transfer can be
;            determined by examining the TRANSFER_COUNT.
;
;
; KEYWORD PARAMETERS:
;
;   TRANSFER_COUNT - upon output, contains the number of elements
;                    transferred to BUFFER.
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 02 Oct 1999, CM
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxgread.pro,v 1.3 2007/09/01 23:03:23 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXGSEEK
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Perform a seek operation on a generic resource.
;
; MAJOR TOPICS:
;   File I/O, Pipes, URLs, FITS
;
; CALLING SEQUENCE:
;   FXGSEEK,  UNIT, POSITION   ;; Sets the current file position
;   FXGSEEK, -UNIT, POSITION   ;; Queries the current file position
;
; DESCRIPTION:
;
;   FXGSEEK performs a seek on the selected resource.  Depending on
;   the sign of UNIT, the current file position is either queried or
;   set, in much the same manner as the built-in IDL procedure
;   POINT_LUN.
;
;   If the resource is a stream, the seek operation does not
;   necessarily force a read until FXGREAD is called (i.e., reads are
;   "lazy").
;
;   You must use the specialized 'FXG' style functions to read, write
;   and seek on file units opened with FXGOPEN:
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; INPUTS:
;
;   UNIT - the unit number to operate on.  The unit must have been
;          previously opened by FXGOPEN.  The operation of FXGSEEK
;          depends on the sign of UNIT.  If UNIT is positive, then the
;          current file position of file UNIT is set to POSITION.  If
;          UNIT is negative, then the current file position of file
;          |UNIT| is placed in the variable POSITION.
;
;   POSITION - Depending on the sign of UNIT, the behavior is
;              different.  When UNIT is positive, POSITION is an input
;              variable containing the new file position.  When UNIT
;              is negative, POSITION is an output variable to contain
;              the file's current file position.
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 02 Oct 1999, CM
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxgseek.pro,v 1.3 2007/09/01 23:03:23 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXGWRITE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Perform an unformatted write to a generic resource.
;
; MAJOR TOPICS:
;   File I/O, Pipes, URLs, FITS
;
; CALLING SEQUENCE:
;   FXWRITE, UNIT, BUFFER, TRANSFER_COUNT=TC
;
; DESCRIPTION:
;
;   FXGWRITE performs an unformatted write to the unit UNIT.  The UNIT
;   must have previously been opened by FXGOPEN with write access.
;
;   Currently only unformatted reads are permitted because the precise
;   number of bytes to written must be known ahead of time.
;
;   In other respects, this procedure is similar to the WRITEU
;   built-in IDL procedure.
;
;   You must use the specialized 'FXG' style functions to read, write
;   and seek on file units opened with FXGOPEN:
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; INPUTS:
;
;   UNIT - the unit number to operate on.  The unit must have been
;          previously opened by FXGOPEN.
;
;   BUFFER - the array to be written. Only basic types are permitted.
;            The actual number of bytes transferred can be determined
;            by examining the TRANSFER_COUNT.
;
;
; KEYWORD PARAMETERS:
;
;   TRANSFER_COUNT - upon output, contains the number of elements
;                    transferred from BUFFER.
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 02 Oct 1999, CM
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxgwrite.pro,v 1.3 2007/09/01 23:03:23 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXMAKEMAP
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Change configuration of FXG - FXFILTER'ed behavior
;
; MAJOR TOPICS:
;   File I/O, Pipes, URLs, FITS
;
; CALLING SEQUENCE:
;   FXMAKEMAP, SUFFIX, COMMAND              or
;   FXMAKEMAP, /INFO                        or
;   FXMAKEMAP, [SCRATCH_DIR=scratch,] [BUFFER_MAX=bufmax,] 
;     [BUFFER_GRAN=bufgran,] [RM_COMMAND=rmcommand,] [/GET]
;
; DESCRIPTION:
;
;   FXMAKEMAP queries or sets the behavior of the FXFILTER family of
;   functions (FXGOPEN, FXGREAD, FXGWRITE, FXGSEEK, and FXGCLOSE).
;
;   To add a new file extension mapping, which associates a filename
;   suffix with a particular Unix pipe command, use the first form of
;   the command.
;
;   To print the current settings, including the file extension maps,
;   use the /INFO form of the command.
;
;   To set an individual parameter, call FXMAKEMAP with the
;   appropriate keyword argument.
;
;   To query an individual parameter, call FXMAKEMAP with /GET and the
;   appropriate keyword argument.
;
; INPUTS:
;
;   SUFFIX - the trailing suffix of the filename to be associated,
;            *without* the period.  For example, for a gzipped file,
;            the suffix is 'gz'
;
;   COMMAND - an IDL-style format command which specifies how the
;             filename should be converted into a Unix pipe command.
;             The actual command is constructed by passing the
;             filename to STRING() with this format string.  For
;             example, to convert a gzip file the proper format string
;             is, '("gzip -dc ",A0)'.
;
; KEYWORD PARAMETERS:
;
;   INFO - print the current settings and return.
;  
;   GET - if this keyword is set, then the following keyword commands
;         cause the current setting to be returned in the specified
;         keyword.  Otherwise the default is to assert a new setting.
;
;   BUFFER_GRAN - the buffer granularity in bytes.  I/O operations on
;                 pipes and streams are performed in multiples of this
;                 size.  Default: 4096 bytes.
;
;   BUFFER_MAX - the maximum allowed buffer size in bytes.  I/O
;                operations on pipes and streams are performed with at
;                most this many bytes.  Default: 32 kbytes.
;
;   RM_COMMAND - the Unix command used to delete files.  
;                Default:  '/bin/rm'
;
;   SCRATCH_DIR - the scratch directory where cache files are stored.
;                 When operations on Unix pipes or streams are
;                 performed, the data are stored in individual files
;                 in this directory.
;
; MODIFICATION HISTORY:
;   Written, 1999, CM
;   Documented, 02 Oct 1999, CM
;   Changed copyright notice, 21 Sep 2000, CM
;   2012-04-17 Promote file position pointers to LONG64, CM
;
;  $Id: fxmakemap.pro,v 1.6 2012/04/17 18:31:38 cmarkwar Exp $
;
;-
; Copyright (C) 1999-2000, 2012 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXPBUFFR
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Internal routine to read data from the pipe and store it in a
;            cache file.
;
; DESCRIPTION:
;
;   See the following procedures for appropriate documentation.
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; PARAMETERS
;   unit - LUN of the pipe, *not* the cache file.
;
;   newlen - the new desired length of the file.  After a successful
;            call to FXPBUFFR, the length of the cache file will be at
;            least this long.
;
; Side Effects
;
;  The pipe is read and the cache increases in size.
;
; MODIFICATION HISTORY:
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxpbuffr.pro,v 1.3 2007/09/01 23:05:31 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXPCLOSE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Internal routine to close a pipe file.
;
; DESCRIPTION:
;
;   See the following procedures for appropriate documentation.
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; PARAMETERS
;   unit - LUN of the pipe, *not* the cache file.
;
; Side effects
;   The pipe is closed.
;   The cache file is closed and deleted.
;
; MODIFICATION HISTORY:
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxpclose.pro,v 1.5 2009/02/12 02:32:50 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;
; FXPIPE_COMMON - information related to pipes in the FXFILTER package.
;
;  POINTER     - for each LUN, the current file pointer (a long integer)
;  CACHE_UNIT  - for each pipe LUN, the LUN of the cache file.
;  CACHE_LEN   - for each cache LUN, the number of cached bytes.
;  CACHE_MAX   - for each cache LUN, the maximum size of the cache.
;  CACHE_FILE  - for each pipe LUN, the name of the cache file. (a string)
;  EOF_REACHED - for each pipe LUN, a flag indicating whether the end
;                of the pipe has been reached.
;  PROCESS_ID  - for each pipe LUN, the process ID of the pipe
;                command.
;  BYTELENS    - the length in bytes of each IDL data type.
;
; MODIFICATION HISTORY:
;   2000-09-21 Changed copyright notice
;   2007-09-01 Add CACHE_MAX in anticipation of in-memory caching
;   2012-04-17 Promote file position pointers to LONG64, CM
;
;  $Id: fxpcommn.pro,v 1.4 2012/04/17 18:31:38 cmarkwar Exp $
;
;-
; Copyright (C) 1999-2000, 2007, 2012 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;                         0   1   2   3   4   5   6   7   8   9  10  11  12
            BYTELENS = [-1L,  1,  2,  4,  4,  8, 16, -1, -1, 16, $
                        -1,  -1,  2,  4,  8,  8, -1 ]
        ENDIF
;+
; NAME:
;   FXPOPENR
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Internal routine to open a Unix pipe command for read access.
;
; DESCRIPTION:
;
;   See the following procedures for appropriate documentation.
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; Usage: FXPOPENR, UNIT, COMMAND, ERRMSG=ERRMSG
;
; PARAMETERS
;
;   unit - FXPOPENR returns the pipe LUN, created by GET_LUN in this
;          parameter.  The LUN should not be "pre-opened".
;          Unformatted reads on this LUN should be performed with
;          FXPREAD.
;
;   command - a scalar string, the pipe command to execute.  The
;             standard output of the command is redirected into UNIT.
;             Standard error is not redirected.
;
;             A failure of the command can only be discovered upon
;            trying to read from the LUN with FXPREAD.
;
; Keywords
; 
;   errmsg - If set to defined value upon input, an error message is
;            returned upon output.  If no error occurs then ERRMSG is
;            not changed.  If an error occurs and ERRMSG is not
;            defined, then FXPOPENR issues a MESSAGE.
;
; Side Effects
;
;   The pipe command is opened with SPAWN, and an additional cache file
;   is opened with read/write access.
;
;   The FXFILTER family of commons is updated.
;
; MODIFICATION HISTORY:
;   Changed copyright notice, 21 Sep 2000, CM
;   Added the OPEN,/DELETE keyword, so that tmp-files are
;     automatically deleted when closed, 18 Feb 2006, CM
;   Added quotation marks to the list of characters which are
;     protected, while making a tmpfile name, 22 Oct 2006, CM
;   2012-04-17 Promote file position pointers to LONG64, CM
;
;  $Id: fxpopenr.pro,v 1.8 2012/04/17 18:31:38 cmarkwar Exp $
;
;-
; Copyright (C) 1999-2000,2006 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;  Utility program to protect the pipe command
PRO FXPOPENR_WRAP_CMD, CMD, SHELL
  
;  SHELL = '/bin/sh -c '

  WHILE STRMID(CMD, 0, 1) EQ '|' OR STRMID(CMD, 0, 1) EQ ' ' DO $
    CMD = STRMID(CMD, 1, STRLEN(CMD)-1)
;  CMD = SHELL + '"' + CMD + ' 2>/dev/null"'
  CMD = CMD + ' 2>/dev/null'

  RETURN
END

; Utility program to generate a name for the cache file.  It is
; uniquely generated based on the time, the command string, and the
; current call number.
; 
FUNCTION FXPOPENR_TMPNAME, CMD
@fxfilter
  COMMON FXPOPEN_TMPNAME, RANDOM_SEED, SEQ_COUNTER
  IF N_ELEMENTS(RANDOM_SEED) EQ 0 THEN BEGIN
      RANDOM_VAL  = LONG(SYSTIME(1))
      RANDOM_SEED = LONG(RANDOMU(RANDOM_VAL)*DOUBLE(ISHFT(1L,31)))
      SEQ_COUNTER = 0L
  ENDIF

  ;; Take the first fifteen and  characters of the command
  TMPNAME = STRCOMPRESS(CMD, /REMOVE_ALL)

  ;; Build a unique hash name based on the command, the current time,
  ;; and a session-specific seed.  Possible problem here: if several
  ;; sessions are started at the same time with the same command, and
  ;; the commands are executed at the same second, then the temporary
  ;; name will be the same.  I judge the likelihood of all of these
  ;; events to be small.
  
  B = BYTE(CMD) & N = N_ELEMENTS(B)
  ;; Construct a semi-unique hash value for the command string
  HASH = 0L
  FOR I = 0L, N-1 DO HASH = ISHFT(HASH, 2) XOR B(I)
  HASH = HASH XOR LONG(SYSTIME(1)) XOR RANDOM_SEED XOR ISHFT(SEQ_COUNTER,16)
  SEQ_COUNTER = SEQ_COUNTER + 1

  IF STRLEN(TMPNAME) GT 20 THEN BEGIN
      TMPNAME = STRMID(TMPNAME, 0, 15) + STRMID(TMPNAME, N-6, 5)
      N = 20L
  ENDIF
  NEWNAME = ''
  ;; Strip away any non-alpha characters
  FOR I = 0L, N-1 DO BEGIN
      CC = STRMID(TMPNAME, I, 1)
      IF NOT (CC EQ ' ' OR CC EQ '>' OR CC EQ '&' OR CC EQ '|' OR $
              CC EQ '/' OR CC EQ '*' OR CC EQ '?' OR CC EQ '<' OR $
              CC EQ '\' OR $
              CC EQ '"' OR CC EQ "'") THEN $
        NEWNAME = NEWNAME + CC
  ENDFOR
  IF NEWNAME EQ '' THEN NEWNAME = 'fxp'

  RETURN, SCRATCH_DIR + NEWNAME + STRING(ABS(HASH), FORMAT='(Z8.8)')
END

;; Main entry
PRO FXPOPENR, UNIT, CMD, ERRMSG=ERRMSG, ERROR=error, COMPRESS=compress

;; Access the general FXFILTER family of commons, and the
;; FXPIPE_COMMON, which has pipe-specific info.
  ERROR = -1
@fxfilter
@fxpcommn

  IF N_PARAMS() LT 2 THEN BEGIN
      MESSAGE = 'Syntax:  FXPOPEN, UNIT, COMMAND'
      GOTO, ERR_RETURN
  ENDIF

  ;; Initialize filter flags
  FFLAGS = 1L

  if NOT keyword_set(compress) then begin

      ;; Sorry, useful pipes are only available under Unix.
      IF STRUPCASE(!VERSION.OS_FAMILY) NE 'UNIX' THEN BEGIN
          MESSAGE = 'ERROR: FXPOPENR ONLY FUNCTIONS ON UNIX SYSTEMS.'
          GOTO, ERR_RETURN
      ENDIF

      ;; --------- Begin pipe section
      ;; Wrap the command to make sure it is safe
      NEWCMD = CMD
      FXPOPENR_WRAP_CMD, NEWCMD, SHELL
      
      ;; Run the program
      OLDSHELL = GETENV('SHELL')
      ON_IOERROR, SPAWN_FAILED
      IF OLDSHELL NE '/bin/sh' THEN SETENV, 'SHELL=/bin/sh'
      SPAWN, NEWCMD, UNIT=UNIT, PID=PID
      ON_IOERROR, NULL
      SETENV, 'SHELL='+OLDSHELL(0)
      
      ;; Check for error conditions
      IF UNIT LT 1L OR UNIT GT 128L THEN BEGIN
          SPAWN_FAILED:
          SETENV, 'SHELL='+OLDSHELL(0)
          MESSAGE = 'ERROR: SPAWN of "'+NEWCMD+'" FAILED'
          GOTO, ERR_RETURN
      ENDIF

      FFLAGS = FFLAGS OR 2  ;; This is a pipe
      ;; ---- End pipe section
  endif else begin
      
      ;; Compressed data - no PID
      PID = 0L

      OPENR, UNIT, CMD, /get_lun, /compress, error=error
      if error NE 0 then begin
          MESSAGE = 'ERROR: OPEN of compressed file "'+CMD+'" FAILED'
          GOTO, ERR_RETURN
      endif

      ;; FFLAGS (unchanged since it is not a pipe)

  endelse

  ;; Prepare the FXFILTER dispatch table for function calls
  FILTERFLAG(UNIT)  = 1            ;; Flags: XXX will be updated below!
  SEEK_CMD(UNIT)    = 'FXPSEEK'
  READ_CMD(UNIT)    = 'FXPREAD'
  WRITE_CMD(UNIT)   = '-'          ;; This pipe is not writable
  CLOSE_CMD(UNIT)   = 'FXPCLOSE'

  ;; Start filling in the FXPIPE_COMMON
  POINTER(UNIT)    = 0LL           ;; Start of pipe
  PROCESS_ID(UNIT) = PID           ;; Save process ID of pipe
  
  ;; Build a unique cache name
  CACHE_FILENAME = FXPOPENR_TMPNAME(CMD)

  ;; Open the output cache file, retrieving a LUN
  ON_IOERROR, OPEN_ERROR
  OPENW, CACHE, CACHE_FILENAME, /GET_LUN, /DELETE
  ON_IOERROR, NULL

  FFLAGS = FFLAGS OR 4             ;; On-disk backing store

  ;; Error condition on the cache file
  IF CACHE LT 1 OR CACHE GT 128 THEN BEGIN
      OPEN_ERROR:

      ;; Reset to default behavior
      FILTERFLAG(UNIT)  = 0
      SEEK_CMD(UNIT)    = ''
      READ_CMD(UNIT)    = ''
      WRITE_CMD(UNIT)   = ''
      CLOSE_CMD(UNIT)   = ''
      FREE_LUN, UNIT

      MESSAGE = 'ERROR: Unable to open cache file ' + STRTRIM(CACHE_FILENAME,2)
      GOTO, ERR_RETURN
  ENDIF

  ;; Finish filling the pipe information
  CACHE_UNIT(UNIT)  = CACHE
  CACHE_FILE(UNIT)  = CACHE_FILENAME
  POINTER(UNIT)     = 0  ;; At beginning of pipe
  CACHE_LEN(UNIT)   = 0  ;; Currently no data cached
  CACHE_MAX(UNIT)   = 0  ;; Currently no storage allocated for cache
  EOF_REACHED(UNIT) = 0  ;; Not known to be at end-of-file

  ;; Update filter flags
  FILTERFLAG(UNIT)  = FFLAGS        

  GOOD_RETURN:
  ERROR = 0
  RETURN

  ERR_RETURN:
  IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN
      ERRMSG = MESSAGE
      RETURN
  ENDIF ELSE MESSAGE, MESSAGE
  RETURN
  
END
;+
; NAME:
;   FXPREAD
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Internal routine to read from a Unix pipe.
;
; DESCRIPTION:
;
;   See the following procedures for appropriate documentation.
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; PARAMETERS
;
;   unit - LUN of the pipe command, *not* the cache file.
;
;   buffer - the buffer to accept the data.  Data is read in
;            *unformatted*.
;
; Side Effects
; 
;   The pipe is read as needed and the cache is populated.
;   The file pointer advances.
;
; MODIFICATIONS
;   Corrected error message, 21 Sep 2000, CM
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxpread.pro,v 1.2 2001/03/25 18:10:46 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   FXPSEEK
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Internal routine to perform seek on a Unix Pipe.
;
; DESCRIPTION:
;
;   See the following procedures for appropriate documentation.
;
;     FXGOPEN  - open resource
;     FXGCLOSE - close resource
;     FXGREAD  - read from resource
;     FXGWRITE - write to resource
;     FXGSEEK  - seek on resource (i.e., perform POINT_LUN)
;
;     FXGFILTERED - determine if resource is a normal file.
;
; PARAMETERS
;
;   unit - the pipe LUN.  If positive, then the file pointer is moved
;          to POSITION in the pipe output.  [ In reality the file
;          pointer is moved in the cache file. ]  If negative, then
;          the file pointer of the file unit -LUN is returned in
;          POSITION.
;
;   position - the file pointer, either passed or returned as defined
;              by UNIT.
;
; Side Effects
;
;   The file pointer may be updated.
;   Actual file accesses are postponed until needed (ie, when FXPREAD
;   is called).
;
; MODIFICATION HISTORY:
;   Changed copyright notice, 21 Sep 2000, CM
;
;  $Id: fxpseek.pro,v 1.2 2001/03/25 18:10:47 craigm Exp $
;
;-
; Copyright (C) 1999-2000, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GAPNAN
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 661, Greenbelt, MD 20770
;   Craig.Markwardt@nasa.gov
;
; PURPOSE:
;   Insert NANs in time series gaps to facilitate plotting
;
; MAJOR TOPICS:
;   Time series
;
; CALLING SEQUENCE:
;   GAPNAN, TT, Y1, [Y2,] [Y3,] [Y4,] [Y5], MAXGAP=, GTI=
;
; DESCRIPTION:
;   This procedure is an covenience procedure for plotting time series
;   which may have gaps.  In other words, a time series where there
;   will be time segments of data, and periods of no data which are
;   considered "gaps."  Sometimes it is desireable to plot the data
;   with lines connecting the data, but no lines across gaps.
;
;   GAPNAN will insert NAN values in time series between gaps.
;   Because an IDL line plot will not connect points with NAN values
;   between them, inserting a NAN value is an effective way of
;   suppressing connecting lines between gaps.
;
;   The user can specify gaps in one of two ways, using either the
;   MAXGAP or the GTI keyword.  The user must specify one of these
;   keywords, but not both.  
;
;   The user can specify the maximum allowable gap size between time
;   series samples using the MAXGAP keyword.  If the time step between
;   samples is larger than MAXGAP then a gap is declared.  (This
;   functionality uses the Markwardt library routine GTISEG.)
;
;   The GTI keyword explicitly designates "good" time intervals.  The
;   user should pass a 2xn array using the GTI keyword, which indicate
;   the start/stop time of each good-time.   If the time samples cross
;   between good time intervals (or if a time sample is noth within a
;   good interval at all), then a gap is declared.  (This
;   functionality uses the Markwardt library routine GTIWHERE.)
;
;   The values Y1, Y2, etc. are the dependent variables.  Up to five
;   dependent variables can be adjusted in one call.
;
; INPUTS:
;   TIME - time variable, used to find gaps.  Upon return, TIME will
;          be modified in-place.  Whereever gaps occur, a new time
;          value will be inserted with the value of NAN.
;
; OPTIONAL INPUTS:
;   Y1, Y2, Y3, Y4, Y5 - the optional dependent variable.  Must have
;          the same number of elements as TIME.  Wherever NANs were
;          inserted in the TIME array, NANs will also be inserted at
;          the corresponding positions of Y1, Y2, etc.  Upon return,
;          these parameters will be modified in-place.  The user may
;          pass up to five dependent variables in one call.
; 
; INPUT KEYWORD PARAMETERS:
;   MAXGAP - maximum gap size between segments, in the same units as
;            the TIME variable.   The user must specify either MAXGAP
;            or GTI, but not both.
;
;   GTI - a 2xN array, in the same units as the TIME variable,
;         indicating "good" time intervals.  The user must specify
;         either MAXGAP or GTI, but not both.
;
; EXAMPLE:
;   ;; Sample data with gap between 3 and 10
;   tt = [1,2,3,    10, 11, 12d]
;   yy = [1,1,1,    2,  2,  2d ]
;   gapnan, tt, yy  maxgap=5

;   ;; Note that a NaN is inserted between 3 and 10, since the actual gap of
;   ;; 7 is larger than the maximum of 5.
;
;
;   ;; Sample data with gap between 3 and 10
;   tt = [1,2,3,    10, 11, 12d]
;   yy = [1,1,1,    2,  2,  2d ]
;
;   ;; Good times from 0.5-2.5 and 10.5-13.0
;   gti = [[0.5,2.5], [10.5,13]]
;   gapnan, tt, yy, gti=gti
;
;   ;; Note that a Nan is inserted between 2 and 3 because the good
;   ;; interval stops at 2.5; a Nan is inserted between 3 and 10, and
;   ;; 10 and 11 because neither 3 nor 10 are within a good interval.
;
;
; MODIFICATION HISTORY:
;   Written and documented, 2010-04-27 CM
;   Added MAXGAP and GTI keywords, 2010-11-13 CM
;   Square bracket array notation, 2011-12-21 CM
;   Bug fix for more than one input array (was ignored), 2012-02-20 CM
;   Bug fix when input GTI is set; defend against array bounds error;
;     add USAGE message, 2013-03-16 CM
;
;-
;+
; NAME:
;   GAUSS1
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Compute Gaussian curve given the mean, sigma and area.
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   YVALS = GAUSS1(XVALS, [MEAN, SIGMA, AREA], SKEW=skew)
;
; DESCRIPTION:
;
;  This routine computes the values of a Gaussian function whose
;  X-values, mean, sigma, and total area are given.  It is meant to be
;  a demonstration for curve-fitting.
;
;  XVALS can be an array of X-values, in which case the returned
;  Y-values are an array as well.  The second parameter to GAUSS1
;  should be an array containing the MEAN, SIGMA, and total AREA, in
;  that order.
;
; INPUTS:
;   X - Array of X-values.
;
;   [MEAN, SIGMA, AREA] - the mean, sigma and total area of the 
;                         desired Gaussian curve.
;
; INPUT KEYWORD PARAMETERS:
;
;   SKEW - You may specify a skew value.  Default is no skew.
;
;   PEAK - if set then AREA is interpreted as the peak value rather
;          than the area under the peak.
;
; RETURNS:
;
;   Returns the array of Y-values.
;
; EXAMPLE:
;
;   p = [2.2D, 1.4D, 3000.D]
;   x = dindgen(200)*0.1 - 10.
;   y = gauss1(x, p)
;
;   Computes the values of the Gaussian at equispaced intervals
;   (spacing is 0.1).  The gaussian has a mean of 2.2, standard
;   deviation of 1.4, and total area of 3000.
;
; REFERENCES:
;
; MODIFICATION HISTORY:
;   Written, Jul 1998, CM
;   Correct bug in normalization, CM, 01 Nov 1999
;   Optimized for speed, CM, 02 Nov 1999
;   Added copyright notice, 25 Mar 2001, CM
;   Added PEAK keyword, 30 Sep 2001, CM
;
;  $Id: gauss1.pro,v 1.4 2001/10/13 17:41:48 craigm Exp $
;
;-
; Copyright (C) 1998,1999,2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GAUSS1P
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Compute Gaussian curve given the mean, sigma and area (procedure).
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   GAUSS1, XVALS, [MEAN, SIGMA, AREA], YVALS, SKEW=skew
;
; DESCRIPTION:
;
;  This routine computes the values of a Gaussian function whose
;  X-values, mean, sigma, and total area are given.  It is meant to be
;  a demonstration for curve-fitting.
;
;  XVALS can be an array of X-values, in which case the returned
;  Y-values are an array as well.  The second parameter to GAUSS1
;  should be an array containing the MEAN, SIGMA, and total AREA, in
;  that order.
;
; INPUTS:
;   X - Array of X-values.
;
;   [MEAN, SIGMA, AREA] - the mean, sigma and total area of the 
;                         desired Gaussian curve.
;
;   YVALS - returns the array of Y-values.
;
;
; KEYWORD PARAMETERS:
;
;   SKEW - You may specify a skew value.  Default is no skew.
;
; EXAMPLE:
;
;   p = [2.2D, 1.4D, 3000.D]
;   x = dindgen(200)*0.1 - 10.
;   gauss1p, x, p, y
;
;   Computes the values of the Gaussian at equispaced intervals
;   (spacing is 0.1).  The gaussian has a mean of 2.2, standard
;   deviation of 1.4, and total area of 3000.
;
; REFERENCES:
;
; MODIFICATION HISTORY:
;   Transcribed from GAUSS1, 13 Dec 1999, CM
;   Added copyright notice, 25 Mar 2001, CM
;
;  $Id: gauss1p.pro,v 1.2 2001/03/25 18:55:12 craigm Exp $
;
;-
; Copyright (C) 1999,2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GAUSS2
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Compute Gaussian curve given the mean, sigma and area.
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   YVALS = GAUSS2(X, Y, [XCENT, YCENT, SIGMA, PEAK])
;
; DESCRIPTION:
;
;  This routine computes the values of a Gaussian function whose
;  X-values, mean, sigma, and total area are given.  It is meant to be
;  a demonstration for curve-fitting.
;
;  XVALS can be an array of X-values, in which case the returned
;  Y-values are an array as well.  The second parameter to GAUSS1
;  should be an array containing the MEAN, SIGMA, and total AREA, in
;  that order.
;
; INPUTS:
;   X - 2-dimensional array of "X"-values.
;   Y - 2-dimensional array of "Y"-values.
;
;   XCENT - X-position of gaussian centroid.
;   YCENT - Y-position of gaussian centroid.
;
;   SIGMA - sigma of the curve (X and Y widths are the same).
;
;   PEAK - the peak value of the gaussian function.
;
; RETURNS:
;
;   Returns the array of Y-values.
;
; EXAMPLE:
;
;   p = [2.2D, -0.7D, 1.4D, 3000.D]
;   x = (dindgen(200)*0.1 - 10.) # (dblarr(200) + 1)
;   y = (dblarr(200) + 1) # (dindgen(200)*0.1 - 10.)
;   z = gauss2(x, y, p)
;
;   Computes the values of the Gaussian at equispaced intervals in X
;   and Y (spacing is 0.1).  The gaussian has a centroid position of
;   (2.2, -0.7), standard deviation of 1.4, and peak value of 3000.
;
; REFERENCES:
;
; MODIFICATION HISTORY:
;   Written, 02 Oct 1999, CM
;   Added copyright notice, 25 Mar 2001, CM
;
;  $Id: gauss2.pro,v 1.2 2001/03/25 18:55:13 craigm Exp $
;
;-
; Copyright (C) 1999,2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GEOGRAV
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Estimate gravitational potential and acceleration by harmonic expansion
;
; MAJOR TOPICS:
;   Physics, Gravity, Geodesy, Spacecraft Navigation
;
; CALLING SEQUENCE:
;   GEOGRAV, GEOGMOD, R, PHI, A [, NMAX=NMAX, MMAX=MMAX, UNITS=UNITS]
;
; DESCRIPTION:
;
;   GEOGRAV estimates the gravitational potential and acceleration due
;   to a non-point central body such as the Earth.  The computation is
;   based on an expansion of the potential spherical harmonics.  The
;   coefficients of the expansion, the Cnm and Snm, are assumed to be
;   known, and available in the GEOGMOD structure (see GEOGREAD).
;   Various gravity solutions are available.
;
;   The user specifies the geocentric position of interest, referred
;   to the earth-fixed coordinates.  The result is the *inertial*
;   gravitational potential and acceleration, expressed in earth-fixed
;   coordinates (i.e., no fictitious potentials or accelerations are
;   applied).  Users should normally rotate the acceleration into
;   inertial coordinates.
;
;   Users can restrict the degree and order of the potential
;   evaluation using the NMAX (order) and MMAX (degree) keywords.
;
;   Input *and* output units are specified using the UNITS keyword,
;   which is an integer value between 1 and 3. The allowed values are:
;
;      UNITS        Accel.       Pot.      Position
;        1  (cgs)   cm/s^2      (cm/s)^2      cm
;        2  (mks)   m/s^2       (m/s)^2        m
;        3  (km)    km/s^2      (km/s)^2      km
;   Note that the input coordinate units must match the desired output
;   units.
;
; INPUTS:
;
;   GEOGMOD - gravity model structure, as returned by GEOGREAD.
;
;   R - earth-fixed position(s) of interest.  Either a 3-vector, for a
;       single evaluation, or a 3xN array, for evaluations of N
;       vectors.
;
;   PHI - upon return, the potential(s). Either a scalar or an
;         N-vector, depending on R.
;
;   A - upon return, the acceleration(s).  Either a 3-vector or a 3xN
;       array, depending on R.
;
;
; KEYWORD PARAMETERS:
;
;   NMAX - maximum spherical harmonic order to evaluate
;
;   MMAX - maximum spherical harmonic degree to evaluate
;
;   UNITS - specifies input and output physical units (see above).
;
;
; IMPLEMENTATION NOTE:
;
;   The computations in this routine are based on recursion relations
;   for fully-normalized associated Legendre polynomials.  They should
;   be stable (and avoid underflow) for evaluations of high order
;   expansions.
;
; EXAMPLE:
;   GEOGREAD, 'egm96', egm96
;   GEOGRAV, egm96, r, phi, a
;
;   Read the gravity model "EGM96" and evaluate it at position "R" in
;   body coordinates.  The potential and acceleration are returned in
;   PHI and A.
;
; REFERENCES:
;
;   Holmes, S. A. & Featherstone, W. E. 2002, "A unified approach to
;     the Clenshaw summation and the recursive computation of very
;     high degree and order normalised associated Legendre functions,"
;     J. Geodesy, 76, 279
;
;   McCarthy, D. D. (ed.) 1996: IERS Conventions, IERS T.N. 21.
;     http://maia.usno.navy.mil/conventions.html
;
;   Pines, S. 1973, "Uniform Representation of the Gravitational
;     Potential and its Derivatives," AIAA J., 11, 1508
;
;   Roithmayr, C. 1996, "Contributions of Spherical Harmonics to
;     Magnetic and Gravitational Fields," NASA Memo, NASA Johnson
;     Space Center, Houston, Texas, USA, 23 Jan 1996
;     (Republished as: NASA/TM2004213007, March 2004
;      URL: http://nssdcftp.gsfc.nasa.gov/models/geomagnetic/igrf/old_matlab_igrf/Contributions.pdf )
;
;   Seidelmann, P.K. 1992, *Explanatory Supplement to the Astronomical
;     Almanac*, ISBN 0-935702-68-7
;
;
; MODIFICATION HISTORY:
;   Written and documented, 05 Jan 2004, CM
;   Documentation additions, CM, 26 Sep 2004
;   Add missing UNITIZE function, CM, 19 Nov 2004
;   Allow MMAX=0 case, CM, 2011-06-26
;
; TODO:
;   Allow perturbations of the main coefficients, because of tides.
;
;  $Id: geograv.pro,v 1.9 2012/02/19 22:44:40 cmarkwar Exp $
;
;-
; Copyright (C) 2004, 2011, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; Utility routine to compute unit vector for each vector
function geograv_unitize, u
  uu = sqrt(total(u^2,1))
  nu = n_elements(uu)
  if nu EQ 1 then return, u/uu(0)
  
  return, u / rebin(reform(uu,1,nu),3,nu)
end

; Main routine to compute gravity for one position
pro geograv_one, geogmod, r, phi, a, $
                 nmax=nmax, mmax=mmax, $
                 unitfact=unitfact, C=C, S=S

  ;; Units        Accel.       Pot.      Position
  ;;  1 - cgs,    cm/s^2      (cm/s)^2      cm
  ;;  2 - mks,    m/s^2       (m/s)^2        m
  ;;  3 - km,     km/s^2      (km/s)^2      km

  rmean = geogmod.a   ;; Mean equatorial radius, in meters always
  mu    = geogmod.mu  ;; GM, in m^3/s^2 always

  rhat = geograv_unitize(r)
  rr = sqrt(total(r^2,1)) / unitfact
  u = rhat(2)

  rho = rmean/rr
  zero = rho*0.

  ;; Pines r_m, i_m.  Uninitialized array, plus the first two
  ;; components to start the recursion relation
  rm = fltarr(mmax+3) + zero & im = rm
  rm(0) = 1 & rm(1) = rhat(0)
  im(0) = 0 & im(1) = rhat(1)

  ;; NORMALIZED Pines Anm matrix.  We only keep one column at a time,
  ;; and the previous one.  Initialize as if we were doing n=1
  Anm = rm*0   & An_1m = Anm
  Anm(0:1) = [u,1]*sqrt(3d)
  An_1m(0) = 1

  ;; Index counters
  nn = lindgen(nmax+2)
  mm = lindgen(mmax+2)

  ;; rho_(n+1) - is overall radial scale factor.  NOTE: (mu/rr) term
  ;;             comes at the end.  We start at n = 1
  rho_n1 = (rmean/rr)^2
  rho_n  = (rmean/rr)

  ;; n = 0 term of Pines eqns (30)
  ax = 0d & ay = 0d & az = 0d

  ;; Pines eqns (30b) -- dominant spherical term (NOTE again, -mu/rr
  ;;                     term comes at the end)
  ar = - C(0,0) / rr  ;; radial accel
  phi = C(0,0)        ;; potential

  ;; Note: start at n = 1
  n = 1L
  while (n LE nmax) do begin
      ;; Extract normalized Cnm and Snm coefficients
      mmax1 = n < mmax
      Cnm = reform(C(n,0:mmax1)) & Snm = reform(S(n,0:mmax1))

      ;; Also the rm and im coefficients
      rmm = rm(0:mmax1)  & imm = im(0:mmax1)
      if mmax1 GT 0 then begin
         rm1 = [0,rm(0:mmax1-1)] & im1 = [0,im(0:mmax1-1)]
      endif else begin
         rm1 = [0]               & im1 = [0]
      endelse

      ;; Pines eqns (27), multipliers for potential and gradient
      Dnm = Cnm*rmm + Snm*imm
      Enm = Cnm*rm1 + Snm*im1
      Fnm = Snm*rm1 - Cnm*im1

      ;; This is the derivative of Anm with respect to u, NORMALIZED
      if mmax GE 1 then begin
         Apnm = [Anm(1:mmax), 0]
      endif else begin
         Apnm = [0]
      endelse
      Apnm = Apnm * sqrt((n+mm+1d)*(n-mm)>0d)
      Apnm(0) = Apnm(0) / sqrt(2d)  ;; Special normalization for m=0

      ;; Compute accelerations for this order.
      ;; Pines eqns (30) - NOTE: Anm is NORMALIZED
      ;; Note the sum over m
      ax = ax + (rho_n1/rmean) * total(Enm*Anm*mm)
      ay = ay + (rho_n1/rmean) * total(Fnm*Anm*mm)
      az = az + (rho_n1/rmean) * total(Dnm*Apnm)

      ;; Compute radial accel, Pines eqn (30a).  Note, can't use eqn
      ;; (30b) because of normalization issues.
      ar = ar - (rho_n1/rmean) * total(Dnm*((n+1d +mm)*Anm + u*Apnm))

      ;; Potential, Pines eqn (11)
      phi = phi + rho_n * total(Dnm*Anm)


      ;; =================
      ;; Increment to next value of n
      n = n + 1
      if n GT nmax then goto, END_N_LOOP

      ;; ----- Find next values of important matrices 
      tn = 2d*n & tnm1 = 2d*n-1d & tnp1 = 2d*n+1d
          
      ;; === Anm
      An_2m = An_1m ;; Move "n-1" column to "n-2" column 
      An_1m = Anm   ;; Move "n"   column to "n-1" column 
      
      ;; Initialize the recurrence (Pines eqns 23) - NORMALIZED
      ;; note: keeping these sqrt()'s distinct improves precision
      Anm(n) = sqrt(tnp1)/sqrt(tn)*An_1m(n-1)

      ;; Holmes & Featherstone eqns (12) - NORMALIZED
      ;; note: keeping these sqrt()'s distinct improves precision
      mmm = mm(0:n-1)
      xm = sqrt(tnm1*tnp1)/sqrt(double((n-mmm)*(n+mmm)))
      ym = sqrt(tnp1*(n+mmm-1d)*(n-mmm-1d))/sqrt((n-mmm)*(n+mmm)*(2d*n-3d))

      ;; Holmes & Featherstone eqn (11) - NORMALIZED
      Anm(0:n-1) = xm*u*An_1m(0:n-1) - ym*An_2m(0:n-1)

      ;; == rm and im, next terms in recurrence
      rm(n) = rm(1) * rm(n-1) - im(1) * im(n-1)
      im(n) = im(1) * rm(n-1) + rm(1) * im(n-1)

      ;; == rho_n1 ... simple geometric sequence
      rho_n1 = rho_n1 * (rmean/rr)
      rho_n  = rho_n  * (rmean/rr)
      
  endwhile

END_N_LOOP:
  ;; NOTE: now must normalize by (mu/rr)
  phi = phi * (-mu/rr) * unitfact^2

  ;; Compose the cartesian and radial components of the acceleration
  a = [ax,ay,az] + ar*rhat
  a = a * (mu/rr) * unitfact

  return
end

pro geograv, geogmod, r, phi, a, nmax=nmax0, mmax=mmax0, units=units0

  sz = size(geogmod)
  if sz(sz(0)+1) NE 8 then begin
      GEOGMOD_ERROR:
      message, 'ERROR: GEOGMOD must be a gravity model structure', /info
      return
  endif

  ;; Be sure it is a gravity structure
  isgrav = 0
  catch, catcherr
  if catcherr EQ 0 then isgrav = (geogmod.type EQ 'GRAVITY')
  catch, /cancel
  if isgrav EQ 0 then goto, GEOGMOD_ERROR

  if n_elements(nmax0) EQ 0 then nmax = geogmod.nmax else nmax = floor(nmax0(0))
  if n_elements(mmax0) EQ 0 then mmax = geogmod.mmax else mmax = floor(mmax0(0))
  nmax = nmax < geogmod.nmax
  mmax = mmax < geogmod.mmax < nmax

  if n_elements(units0) EQ 0 then begin
      units = 2
  endif else begin
      units = floor(units0(0))
  endelse
  case units of 
      1: unitfact = 100d
      2: unitfact = 1d
      3: unitfact = 0.001d
      else: begin
          message, 'ERROR: UNITS must be one of 1, 2, or 3', /info
          return
      end
  endcase

  ;; Retrieve the normalized coefficients
  C = *(geogmod.Cnm)
  S = *(geogmod.Snm)

  nv = n_elements(r)/3
  a   = fltarr(3,nv) + r(0)*0
  phi = fltarr(nv) + r(0)*0   & if nv EQ 1 then phi = phi(0)
  for i = 0L, nv-1 do begin
      geograv_one, geogmod, r(*,i), phi1, a1, C=C, S=S, $
        nmax=nmax, mmax=mmax, unitfact=unitfact
      
      a(*,i) = a1
      phi(i) = phi1
  endfor

  return
end
;+
; NAME:
;   GEOGREAD
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Read gravity model from disk file
;
; MAJOR TOPICS:
;   Physics, Gravity, Geodesy, Spacecraft Navigation
;
; CALLING SEQUENCE:
;   GEOGREAD, ROOTFILE, MODEL [, STATUS=STATUS, ERRMSG=ERRMSG,
;                               /COEFF_ERR]
;
; DESCRIPTION:
;
;   GEOGREAD reads a gravity model from a disk file.  The gravity
;   model must have already been prepared.  There are a number of
;   freely available models.
;
;   Each model must have a "description" file which describes, in IDL
;   syntax, the name, content and format of the model file.  The
;   ROOTFILE parameter is the name of this description file.  The
;   description must provide the name of the model file (the FILENAME
;   field), which must reside in the same directory.
;
; FILE FORMAT:
;
;   The format of the description file (and hence also the format of
;   the structure returned in GEOGMOD), is as follows, an example
;   modified from egm96.desc:
;
; { $
;   name: 'EGM96', $              ;; Title of the model
;   type: 'GRAVITY', $            ;; Type of model 'GRAVITY' or 'BFIELD'
;   filename: 'EGM96.GEO', $      ;; Model coefficient file name (same dir)
;   reference: 'Lemoine, ...'     ;; Complete literature reference
;   url: 'ftp://ftp.csr.utexas.edu/pub/grav/EGM96.GEO.Z', $   ;; Source URL
;   nmax: 360L, $                 ;; Maximum order (inclusive)
;   mmax: 360L, $                 ;; Maximum degree (inclusive)
;   normalized: 1, $              ;; Coefficients are normalized (1=yes, 0=no)
;   mu: 398600.44150D+09, $       ;; GM for central body [m^3/s^2]
;   a: 6378136.30d, $             ;; Mean equatorial radius [m]
;   tide: 'ZERO', $               ;; Tide system (ZERO, FREE, or MEAN)
;   epoch: 1986.0d, $             ;; Epoch of model coefficients (Julian year)
;   C21: -.1869876359548955D-09,$ ;; C21 coefficient (if not in Cnm table)
;   S21:  .1195280120306540D-08,$ ;; S21 coefficient (if not in Cnm table)
;   C20_dot: 1.16275534D-11,$     ;; C20 rate (unitless; yr^-1)
;   C21_dot: -0.32d-11, $         ;; C21 rate (unitless; yr^-1)
;   S21_dot: +1.62d-11, $         ;; S21 rate (unitless; yr^-1)
;   rowstart: 4L, $               ;; Coefficient starting row (first row = 0)
;   nrows: 65338L, $              ;; Number of coefficient rows in file
;   ncolrange: [6,8], $           ;; Column range for degree (first col = 0)
;   mcolrange: [9,11], $          ;;    "     "    "  order 
;   Ccolrange: [12,30], $         ;;    "     "    "  C coefficients
;   Scolrange: [31,49], $         ;;    "     "    "  S coefficients
;   dCcolrange: [50,62], $        ;;    "     "    "  C std deviation
;   dScolrange: [63,75] $         ;;    "     "    "  S std deviation
; }
;
;   The xCOLRANGE fields describe which character columns in the model
;   file, inclusive, contain the quantity of interest.  You can use a
;   text editor which reports the column number to find these values.
;   Exclude any character columns that contain field delimiters such
;   as commas.
;
;   Since the C21 and S21 coefficients are commonly not included in
;   the table itself, their values are allowed to be specified in the
;   description file.  If the coefficients *are* in the table, then
;   they must be set to zero in the description file to avoid double
;   computations.  The coefficient rates can be used to extrapolate to
;   different epochs from the reference epoch (specified by EPOCH).
; 
;
; INPUTS:
;
;   ROOTFILE - scalar string, the name of the model description file.
;
;   GEOGMOD - upon return, an IDL structure containing the model
;             information.  In addition to the fields listed above,
;             other fields are appended which contain (pointers to)
;             the coefficient data, etc.
;
; KEYWORD PARAMETERS:
;
;   STATUS - upon return, a status indicator.  A value of 1 is OK, 0
;            indicates an error condition.
;
;   ERRMSG - upon return, an error message, if any.  If no error
;            occurred, then ERRMSG is set to ''.
;
;   CEOFF_ERR - if set, then coefficient standard deviations are also
;               read in.q
;
;
; EXAMPLE:
;   GEOGREAD, 'egm96', egm96
;   GEOGRAV, egm96, r, phi, a
;
;   Read the gravity model "EGM96" and evaluate it at position "R" in
;   body coordinates.  The potential and acceleration are returned in
;   PHI and A.
;
; MODIFICATION HISTORY:
;   Documentation additions, CM, 26 Sep 2004
;
;  $Id: geogread.pro,v 1.3 2004/09/26 14:58:19 craigm Exp $
;
;-
; Copyright (C) 2004, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GTI2MASK
;   
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Convert Good Time Interval (GTI) to evenly sampled mask array
;
; CALLING SEQUENCE:
;   MASK = GTI2MASK(GTI, [TIME, TLIMITS=, TIMEDEL=, NTBINS=,
;                   GOOD=, BAD=, /FILL, /INVERT])
;
; DESCRIPTION: 
;
;   The function GTI2MASK converts an existing valid Good Time
;   Interval (GTI) array to a mask array.  By definition a GTI
;   indicates an array of intervals which are not on an evenly sampled
;   array.  This routine either accepts a time grid from the user, or
;   the grid must be described by the TLIMITS and TIMEDEL keywords.
;
;   The output mask array describes whether each grid point lies
;   within a good interval or not.  There is full control over the
;   values of the good and bad values.
;
;   This routine is the inverse of MASK2GTI.
;
;   It should be noted that this function is not constrained to
;   operation only on time arrays.  It should work on any
;   one-dimensional quantity with intervals.
;
; INPUTS:
;
;   GTI - a 2xNINTERVAL array where NINTERVAL is the number of
;         intervals.  GTI(*,i) represent the start and stop times of
;         interval number i.  The intervals must be non-overlapping
;         and time-ordered (use GTITRIM to achieve this).
;
;         A scalar value of zero indicates that the GTI is empty, ie,
;         there are no good intervals.
;
;   TIME - optional time array that specifies the time grid for the
;          mask array.  If TIME is not specified then the user must
;          give the TLIMITS and TIMEDEL keywords to fully describe the
;          grid spacing.  The TIME array is overwritten if the FILL
;          keyword is used.
;
; KEYWORDS:
;
;   TLIMITS - a 2-element array giving the start and stop limits over
;             which the mask array is to be generated.  The TLIMITS
;             and TIMEDEL keywords are required if the TIME parameter
;             is not given.
;
;   TIMEDEL - a scalar specifying the interval between grid points.
;             The TLIMITS and TIMEDEL keywords are required if the
;             TIME parameter is not given.
;
;   NTBINS - upon return, this keyword contains the number of time
;            samples created.
;
;   GOOD - the value of "good" in the output mask array.
;          Default: 1b
;
;   BAD - the value of "bad" in the output mask array.
;         Default: 0b
;
;   INVERT - if set, the array GTI is treated as a "bad" time
;            interval, ie, the GOOD and BAD values are swapped.
;
;   FILL - if set, the array TIME is filled with values determined
;          from the TLIMITS and TIMEDEL keyword.
;
; RETURNS:
;
;   A mask array, either sampled at the points specified by TIME, or
;   by the grid specified by TLIMITS and TIMEDEL.  The "good" value
;   indicates that the point lies within the good interval, while a
;   "bad" value indicates the point was outside.
;
; SEE ALSO:
;
;   MASK2GTI, GTITRIM, GTIMERGE
;
; MODIFICATION HISTORY:
;   Written, CM, 1997-2001
;   Documented, CM, Apr 2001
;   Add internal OVERLAP and MINFRACEXP keywords, CM, 03 Feb 2007
;   Refine and simplify the OVERLAP processing, CM, 14 Feb 2007
;   Handle case of /OVERLAP when there is no intersection, CM, 22 Aug 2007
;   Use VALUE_LOCATE for performance (in non-OVERLAP case), CM, 04 May 2008
;
;  $Id: gti2mask.pro,v 1.7 2008/05/04 21:35:27 craigm Exp $
;
;-
; Copyright (C) 1997-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GTIENLARGE
;   
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Enlarge (or shrink) each Good Time Interval (GTI) by fixed amounts
;
; CALLING SEQUENCE:
;   NEWGTI = GTIENLARGE(GTI, COUNT=COUNT, PRE=PRE, POST=POST)
;
; DESCRIPTION: 
;
;   The function GTIENLARGE accepts an existing valid Good Time
;   Interval (GTI) array and creates a new GTI array in which the
;   intervals have been enlarged (or shrunken) by a fixed amount.
;
;   The keywords PRE and POST are used to specify the enlargement.
;   Given an existing good interval such as this one:
;
;                  100                 200              GTI=[[100,200]]
;      <------------|===================|------------->
;
;   a positive value of PRE will enlarge the lead edge of the interval
;   and a positive value of POST will enlarge the trailing edge of the
;   interval.  Thus PRE=10 and POST=20 will create a new interval from
;   the above example:
;
;               90<--                   --->220      NEWGTI=[[ 90,220]]
;      <---------|==.===================.====|-------->
;             PRE=10                   POST=20
;
;   Negative values of PRE and POST are allowed, which will shrink the
;   interval from the leading and trailing edges respectively.
;
;   Users should be aware that the number of intervals may shrink
;   under this operation, since it is possible either for two
;   intervals to be merged if they are enlarged and overlap, or if
;   they are shrunken to a size of zero.
;
;   It should be noted that this function is not constrained to
;   operation only on time arrays.  It should work on any
;   one-dimensional quantity with intervals.
;
; INPUTS:
;
;   GTI - a 2xNINTERVAL array where NINTERVAL is the number of
;         intervals.  GTI(*,i) represents the start and stop times of
;         interval number i.  The intervals must be non-overlapping
;         and time-ordered (use GTITRIM to achieve this).
;
;         A scalar value of zero indicates that the GTI is empty, ie,
;         there are no good intervals.
;
; KEYWORDS:
;
;   PRE - the amount each interval should be enlarged from its leading
;         edge.  A negative value indicates the interval should
;         shrink.
;         Default: 0
;
;   POST - the amount each interval should be enlarged from its
;          trailing edge.  A negative value indicates the interval
;          should shrink. 
;          Default: 0
;
;   COUNT - upon return, the number of resulting intervals.  A value
;           of zero indicates no good time intervals.
;
; RETURNS:
;
;   A new GTI array containing the enlarged or shrunken intervals.
;   The array is 2xCOUNT where COUNT is the number of resulting
;   intervals.  GTI(*,i) represents the start and stop times of
;   interval number i.  The intervals are non-overlapping and
;   time-ordered. 
;
;   If COUNT is zero then the returned array is a scalar value of
;   zero, indicating no good intervals were found.
;
;
; SEE ALSO:
;
;   GTITRIM, GTIENLARGE
;
; MODIFICATION HISTORY:
;   Written, CM, 1997-2001
;   Documented, CM, Apr 2001
;
;  $Id: gtienlarge.pro,v 1.3 2001/04/30 16:03:03 craigm Exp $
;
;-
; Copyright (C) 1997-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GTIMERGE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Merge two Good Time Interval (GTIs) arrays into a single array
;
; CALLING SEQUENCE:
;   NEWGTI = GTIMERGE(GTI1, GTI2, COUNT=COUNT, [/INTERSECT, /UNION,
;                     /INVERT1, /INVERT2, TTOLERANCE=])
;
; DESCRIPTION: 
;
;   The function GTIMERGE accepts two existing valid Good Time
;   Interval (GTI) arrays and merges them into a single array.  Either
;   the intersection or the union of the two GTIs are returned.
;
;   The intersection refers to the set of intervals which lie in both
;   intervals.  The union refers to the set of intervals which lie in
;   at least one but not necessarily both.  Here is an example of both
;   kinds of operations.  Let us start with two intervals here:
;
;        0              50              100                  170   GTI1
;   <----|==============|----------------|====================|------>
;
;                 30                         120                   GTI2
;   <--------------|==========================|---------------------->
;
;   These intervals would be represented by GTI1=[[0,50],[100,170]]
;   and GTI2=[[30,120]]. The intersection of the two sets of intervals
;   are the points which lie in both, ie [[30,50],[100,120]]:
;
;                 30   50               100  120              INTERSECT
;   <--------------|====|----------------|====|---------------------->
;
;   The union is the combination of both intervals, ie [[0,170]]:
;
;        0                                                   170  UNION
;   <----|====================================================|------>
;
;   It is also possible to treat either one of the input arrays as
;   "bad" intervals using the INVERT1 and/or INVERT2 keywords.  When
;   an interval is inverted, then the output is composed only of areas
;   *outside* the specified intervals.
;
;   It should be noted that this function is not constrained to
;   operation only on time arrays.  It should work on any
;   one-dimensional quantity with intervals.
;
;
; PERFORMANCE:  Combining many intervals
;
;   Users who wish to combine many intervals in sequence will find a
;   performance degradation.  The problem is that each GTIMERGE
;   operation is order N^2 execution time where N is the number of
;   intervals.  Thus, if N mostly distinct GTIs are merged, then the
;   running time will be order N^3.  This is unacceptable, but there
;   is a workaround.
;
;   Users can accumulate "sub" GTIs by merging subsets of the full
;   number of intervals to be merged, and then occasionally merging
;   into the final output GTI.  As an example, here first is a simple
;   merging of 1000 different GTIs:
;
;     totgti = 0L                   ;; Empty GTI
;     FOR i = 0, 999 DO BEGIN
;         gti = ...                
;         totgti = gtimerge(totgti, gti, /union)
;     ENDFOR
;
;   This computation may take a long time.  Instead the merging can be
;   broken into chunks.
;
;     totgti = 0L
;     chgti  = 0L      ;; "Chunk" GTI
;     FOR i = 0, 999 DO BEGIN
;         gti = ...
;         chgti = gtimerge(chgti, gti, /union)
;         if (n_elements(chgti) GT 100) OR (i EQ 999) then begin
;             ;; Merge "chunk" gti into final one, and reset
;             totgti = gtimerge(totgti, chgti, /union)
;             chgti = 0L
;         endif
;     ENDFOR
;
;   Note that the final merge is guaranteed because of the (i EQ 999)
;   comparison.
;
; INPUTS:
;
;   GTI1, GTI2 - the two input GTI arrays.
;
;         Each array is a 2xNINTERVAL array where NINTERVAL is the
;         number of intervals, which can be different for each array.
;         GTI(*,i) represents the start and stop times of interval
;         number i.  The intervals must be non-overlapping and
;         time-ordered (use GTITRIM to achieve this).
;
;         A scalar value of zero indicates that the GTI is empty, ie,
;         there are no good intervals.
;
; KEYWORDS:
;
;   INTERSECT - if set, then the resulting GTI contains only those
;               intervals that are in both input sets.
;
;   UNION - if set, then the resulting GTI contains those intervals
;           that are in either input set.
;
;   COUNT - upon return, the number of resulting intervals.  A value
;           of zero indicates no good time intervals.
;
;   INVERT1 - if set, then GTI1 is considered to be inverted, ie, a
;             set of "bad" intervals rather than good.
;
;   INVERT2 - if set, then GTI2 is considered to be inverted, ie, a
;             set of "bad" intervals rather than good.
;
;   TTOLERANCE - a scalar value indicating the tolerance for
;                determining whether values are equal.  This number
;                can be important for intervals that do not match
;                precisely.
;                Default: Machine precision
;
; RETURNS:
;
;   A new GTI array containing the merged intervals.  The array is
;   2xCOUNT where COUNT is the number of resulting intervals.
;   GTI(*,i) represents the start and stop times of interval number i.
;   The intervals are non-overlapping and time-ordered.
;
;   If COUNT is zero then the returned array is a scalar value of
;   zero, indicating no good intervals were found.
;
; SEE ALSO:
;
;   GTITRIM, GTIENLARGE
;
; MODIFICATION HISTORY:
;   Written, CM, 1997-2001
;   Documented, CM, Apr 2001
;   Handle case of zero-time GTIs, CM, 02 Aug 2001
;   Handle "fractured" GTIs correctly, though worriedly, CM, 15 Oct
;     2001
;   Handle case where both inputs are empty, but /INVERT1 and/or
;     /INVERT2 are set, CM, 08 Aug 2006
;
;  $Id: gtimerge.pro,v 1.7 2006/10/22 09:49:53 craigm Exp $
;
;-
; Copyright (C) 1997-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;      print, '  ', o1(uu(j):uu(j+1)-1), format='(A0,100(D4.0," ",:),$)'
;      print, ' --> ', oo1
;      print, '  ', o2(uu(j):uu(j+1)-1), format='(A0,100(D4.0," ",:),$)'
;      print, ' --> ', oo2

      ;; yes1 and yes2 are updated here, if there is a change in gti state
      if oo1 GE 0 then yes1 = (oo1 EQ 1)
      if oo2 GE 0 then yes2 = (oo2 EQ 1)

      ;; Here are the conditions for starting a new GTI entry
      if (NOT within AND (yes1 OR  yes2) AND keyword_set(union)) OR $
        ( NOT within AND (yes1 AND yes2) AND keyword_set(intersect)) then $
        begin
          tstart = tt(i)
          within = 1
      endif
      if dbl1 AND yes1 then yes1 = 0
      if dbl2 AND yes2 then yes1 = 0

      ;; And the conditions for ending it.
      if (within AND (NOT yes1 AND NOT yes2) AND keyword_set(union)) OR $
        ( within AND (NOT yes1 OR  NOT yes2) AND keyword_set(intersect)) then $
        begin
          if numgti EQ 0 then $
            newgti = [ tstart, tt(i) ] $
          else $
            newgti = [ newgti, tstart, tt(i) ]
          numgti   = numgti + 1
          within   = 0

          if dbl1 OR dbl2 then begin
              ;; Now restart the GTI if desired
              tstart = tt(i)
              within = 1
              dbl1 = 0 & dbl2 = 0
          endif
      endif

      LOOPCONT:
  endfor

  ;; I think this clause is activated only if the INVERT1 or INVERT2
  ;; keywords are activated.  This should be tested.  Boundary
  ;; conditions can be wierd.
  if within then begin
      if numgti EQ 0 then $
        newgti = [ tstart, max(tt) ] $
      else $
        newgti = [ newgti, tstart, max(tt) ]
      numgti   = numgti + 1
      within   = 0
  endif
  
  ;; Empty GTI is a special case.  Here I have opted to *not* take the
  ;; lame HEASARC route.  Instead, I define a single element GTI array
  ;; to mean no good times.
  if numgti EQ 0 then begin
      EMPTY_GTI:
      count = 0L
      return, 0L
  endif

  ;; Reconstitute the new GTI array
  count    = numgti
  newgti   = reform(newgti, 2, numgti, /overwrite)

  ;; Now do some clean-up, removing zero-time GTIs and GTIs that
  ;; adjoin.  This really should not be necessary, since by definition
  ;; the above technique should not create buggy GTIs.
  if numgti GT 0 then begin
      ocount = count
      newgti = gtitrim(newgti, maxgap=ttol, count=count)
  endif

  return, newgti
end
;+
; NAME:
;   GTISEG
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Convert a list of times to a set of Good Time Intervals (GTIs)
;
; CALLING SEQUENCE:
;   GTI = GTISEG(TIMES, COUNT=COUNT, INDICES=INDICES, $
;                MAXGAP=MAXGAP, MINGTI=MINGTI)
;
; DESCRIPTION: 
;
;   The function GTISEG accepts an array of times and converts
;   adjacent data into good time intervals (GTIs).
;
;   Elements of the array are clustered into intervals based on the
;   gaps between times.  If the gaps are small enough then the times
;   are grouped into a single interval.  If a gap exceeds MAXGAP, then
;   an interruption occurs and at least two intervals are formed.
;   Thus, the keyword parameter MAXGAP essentially determines how many
;   and where the intervals will be formed.
;
;   If the time samples are regularly spaced -- aside from gaps --
;   then MAXGAP should be set to a number slightly larger than the
;   spacing to prevent roundoff errors.  By default MAXGAP is set to
;   the difference between the first and second samples.
;
;   For GTISEG, the samples do not need to be regularly spaced, but
;   they *must* be given in ascending order.  Arrays can be sorted
;   with the SORT function.  The primary difference between GTISEG and
;   MASK2GTI is that MASK2GTI assumes the time samples are regularly
;   spaced while GTISEG does not.  Also, MASK2GTI allows intervals to
;   be enlarged or shrunk.
;
;   It should be noted that this function is not constrained to
;   operation only on time arrays.  It should work on any
;   one-dimensional quantity with intervals.
;
; INPUTS:
;
;   TIME - an array of times in ascending order.
;
;
; KEYWORDS:
;
;   MAXGAP - a scalar, the maximum gap between time samples before a
;            new interval is created.  Samples with gaps smaller than
;            this value are grouped into a single GTI.
;            Default: TIME(1) - TIME(0)
;
;   MINGTI - the smallest possible GTI.  Any interval smaller than
;            MINGTI is discarded.
;            Default: 0   (all intervals are accepted)
;
;   COUNT - upon return, the number of resulting intervals.  A value
;           of zero indicates no good time intervals.
;
;   INDICES - upon return, a 2xCOUNT array of integers which give the
;             indices of samples which lie within each interval.  The
;             times TIME(INDICES(0,i) : INDICES(1,i)) fall within the
;             ith interval.
;
; RETURNS:
;
;   A new GTI array containing the enlarged or shrunken intervals.
;   The array is 2xCOUNT where COUNT is the number of resulting
;   intervals.  GTI(*,i) represents the start and stop times of
;   interval number i.  The intervals are non-overlapping and
;   time-ordered. 
;
;   If COUNT is zero then the returned array is a scalar value of
;   zero, indicating no good intervals were found.
;
; SEE ALSO:
;
;   MASK2GTI, GTITRIM, GTIMERGE, GTIWHERE
;
; MODIFICATION HISTORY:
;   Written, CM, 1999-2001
;   Documented, CM, Apr 2001
;   MINGTI now works as documented, in that segments *equal* to MINGTI
;     are now accepted, CM, 30 Oct 2007
;   MINGTI now also affects INDICES, CM, 03 Mar 2008
;
;  $Id: gtiseg.pro,v 1.7 2008/03/23 18:13:13 craigm Exp $
;
;-
; Copyright (C) 1999-2001, 2007, 2008, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GTITRIM
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Normalize a Good Time Interval (GTI) - no overlapping and adjoining
;
; CALLING SEQUENCE:
;   NEWGTI = GTITRIM(GTI, COUNT=, MAXGAP=, MINGTI=)
;
; DESCRIPTION: 
;
;   A good time interval is by definition a list of intervals which
;   represent "good" or acceptable portions of the real number line.
;   In this library a GTI is a 2xNINTERVAL array where NINTERVAL is
;   the number of intervals.
;
;   The numbers in the array represent the start and stop times of
;   each interval.  Thus, the array [[0,10],[20,30],[40,50]] represent
;   intervals ranging from 0-10, 20-30 and 40-50.  Formally, this
;   example GTI represents times which would satisfy the following
;   expression, for each time T and interval number i:
;       T GE GTI(0,i) AND T LT GTI(1,i)
;   Note that the endpoint is closed on the left but open on the
;   right.
;
;   However, not every 2xNINTERVAL array is a valid or "normalized"
;   GTI as used by this library.  The array must satisfy several
;   conditions:
;      * time ordered (ascending)
;      * no overlapping intervals
;      * no adjoining intervals (intervals that start and stop at the
;        same point; e.g. the point 10 in this array [[0,10],[10,20]])
;
;   A user who desires to create his or her own GTI array can proceed
;   as follows.
;
;   First, the array is placed in time order.  This can be
;   accomplished simply using the built-in function SORT.  This
;   statement sorts the array by start times.
;
;       GTI = GTI(*, SORT(GTI(0,*)))
;
;   Second, the GTITRIM function is used to fully normalize the set of
;   intervals:
;
;       GTI = GTITRIM(GTI)
;
;   After these two procedures the GTI is considered valid and can be
;   passed to the other routines of the library.  Of course if the
;   user can guarantee the above requirements without using GTITRIM
;   then this is acceptable as well.
;
;   It should be noted that this function is not constrained to
;   operation only on time arrays.  It should work on any
;   one-dimensional quantity with intervals.
;
; INPUTS:
;
;   GTI - a 2xNINTERVAL array where NINTERVAL is the number of
;         intervals.  GTI(*,i) represents the start and stop times of
;         interval number i.  The intervals must be non-overlapping
;         and time-ordered (use GTITRIM to achieve this).
;
;         A scalar value of zero indicates that the GTI is empty, ie,
;         there are no good intervals.
;
; KEYWORDS:
;
;   MAXGAP - Maximum allowable gap for merging existing good time
;            intervals.  Intervals with gaps smaller than MAXGAP will
;            be combined into a single interval.
;            Default: 0   (any gap keeps intervals separate)
;
;   MINGTI - Minimum size interval.  If any interval is smaller than
;            MINGTI then it is discarded.
;            Default: 0   (all intervals are preserved)
;
;   COUNT - upon return, the number of resulting intervals.  A value
;           of zero indicates no good time intervals.
;
;
; RETURNS:
;
;   A new GTI array containing the normalized intervals.  The array is
;   2xCOUNT where COUNT is the number of resulting intervals.
;   GTI(*,i) represents the start and stop times of interval number i.
;   The intervals are non-overlapping and time-ordered.
;
;   If COUNT is zero then the returned array is a scalar value of
;   zero, indicating no good intervals were found.
;
; SEE ALSO:
;
;   GTIMERGE
;
; MODIFICATION HISTORY:
;   Written, CM, 1997-2001
;   Documented, CM, Apr 2001
;   Corrected bug which bypassed MIN/MAXGTI, CM, 20 Jul 2003
;
;  $Id: gtitrim.pro,v 1.7 2006/10/22 09:50:09 craigm Exp $
;
;-
; Copyright (C) 1997-2001, 2003, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   GTIWHERE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Locate a list of times within a Good Time Interval (GTI) array
;
; CALLING SEQUENCE:
;   WH = GTIWHERE(TIME, GTI, COUNT=, INTERVALS=, /INVERT, /INCLUDE)
;
; DESCRIPTION: 
;
;   The function GTIWHERE is an efficient method to determine which
;   good time interval (GTI) a particular time sample falls into, if
;   any.  The user passes an array of one or more times in the TIME
;   parameter, and GTIWHERE determines which of these times are in a
;   good interval.  The INTERVALS keyword returns an identification of
;   which interval the time fell into.
;
;   It should be noted that this function is not constrained to
;   operation only on time arrays.  It should work on any
;   one-dimensional quantity with intervals.
;
;   The definition of "inside" a good-time interval is
;      TIME GE GTI(0,i) AND TIME LT GTI(1,i)     (INCLUDE=0)
;      TIME GE GTI(0,i) AND TIME LE GTI(1,i)     (INCLUDE=1)
;   where GTI(*,i) is the i'th interval.
;
;   When using /INVERT, the definition of "outside" a bad-time
;   interval is
;      TIME LT GTI(0,i) OR TIME GE GTI(1,i)    (INCLUDE=0)
;      TIME LT GTI(0,i) OR TIME GT GTI(1,i)    (INCLUDE=0)
;
; INPUTS:
;
;   TIME - an array of times, in no particular order.
;
;   GTI - a 2xNINTERVAL array where NINTERVAL is the number of
;         intervals.  GTI(*,i) represents the start and stop times of
;         interval number i.  The intervals must be non-overlapping
;         and time-ordered (use GTITRIM to achieve this).
;
;         A scalar value of zero indicates that the GTI is empty, ie,
;         there are no good intervals.
;
; KEYWORDS:
;
;   COUNT - upon return, the number of resulting intervals.  A value
;           of zero indicates no good time intervals.
;
;   INTERVALS - upon return, an array of integers specifying the
;               interval number each time falls into.  The number of
;               elements of INTERVALS is COUNT (ie, there is one
;               INTERVAL for each returned index).
;
;   INCLUDE - if set then the endpoints are considered closed at both
;             ends; by convention the endpoints are normally treated
;             as closed at the left and open at the right.
;
;   INVERT - if set, the array GTI is treated as a "bad" time
;            interval.  Only times *outside* of the GTI are selected.
;            In this case there are NGTI+1 possible intervals, where
;            NGTI is the number of time intervals passed in GTI.  The
;            indices returned in the INTERVALS keyword start from the
;            "left."
;
; RETURNS:
;
;   An array of integer indices indicating which elements of TIME are
;   within the "good" intervals.  The number of selected elements is
;   COUNT.  If COUNT is zero, then a scalar value of -1L is returned,
;   indicating no selected values.
;
;
; SEE ALSO:
;
;   GTISEG, GTIMERGE, GTIENLARGE
;
; MODIFICATION HISTORY:
;   Written, CM, 1997-2001
;   Documented, CM, Apr 2001
;   Added usage message, CM, 2006 Aug 18
;   Handle the case if /INVERT and /INCLUDE, which changes the
;     boundary conditions slightly, CM, 2007 Dec 15
;   Handle case of empty input GTI and /INVERT; also handle 
;     INVERT in case where MIN(TIME) touches MIN(GTI), CM, 2008 Jul 08
;   Return -1L for no interval found, instead of 0L, CM, 2011 Jan 05
;
;  $Id: gtiwhere.pro,v 1.7 2011/02/09 03:22:48 cmarkwar Exp $
;
;-
; Copyright (C) 1997-2001, 2006, 2007, 2008, 2011 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; CLASS_NAME:
;	HASHTABLE
;
; PURPOSE:
;	A hash table class which associates key strings with arbitrary values
;
; CATEGORY:
;	Data Structures
;
; SUPERCLASSES:
;       None.
;
; SUBCLASSES:
;       This class has no subclasses.
;
; CREATION:
;       See HASHTABLE::INIT
;
; DESCRIPTION:
;
;       This is a hash table class.  With this data structure, users
;       can associate arbitrary values (scalars, arrays, structures,
;       objects, etc) with a scalar string "key."  The hash table is a
;       collection of (key,value) associations.  Users may dynamically
;       add and remove entries.
;
;       Upon initialization, users may choose the size of the hash
;       table.  This size should be larger than the expected number of
;       entries in the table.  Regardless of the size of the table, an
;       essentially unlimited number of entries may be stored.
;
;       Duplicate keys may be allowed or disallowed, depending on the
;       NO_DUPLICATES keyword to the initialization method.
;
;
; METHODS:
;       Intrinsic Methods
;       This class has the following methods:
;
;       HASHTABLE::CLEANUP removes an existing hash table object
;       HASHTABLE::INIT    initializes a new hash table object
;       HASHTABLE::ADD     adds a new entry to an existing hash table object
;       HASHTABLE::COUNT   returns the number of entries in a hash table
;       HASHTABLE::REMOVE  removes an entry from an existing hash table
;       HASHTABLE::ISCONTAINED is a KEYNAME contained within a hash table?
;       HASHTABLE::GET     returns value associated with KEYNAME in hash table
;       HASHTABLE::KEYS    returns all the keys in an existing hash table
;       HASHTABLE::STRUCT  returns hash table, converted to a structure
;
;
; EXAMPLE:
;
;       ;; Create hash table object
;       ht = obj_new('hashtable')
;       
;       ;; Add some entries
;       ht->add, 'one', 1     ;; Add the scalar number 1
;       ht->add, 'two', [1,2] ;; Add a vector [1,2]
;       ht->add, 'struct', {alpha: 1, beta: 2} ;; Add a structure
;       ht->add, 'hash', obj_new('hashtable')  ;; Add another hash table!
;
;       ht->add, 'one', 10    ;; Adding a duplicate entry!!
;       ;; NOTE: if you do not wish to allow multiple entries with the
;       ;; same key, then add entries like this:
;       ht->add, 'one', 10, /replace
;       ;; in which case 10 would replace 1.
;
;       ;; Number of entries stored
;       print, ht->count()
;        ---> 5
;       
;       ;; Retreive some entries
;       print, ht->get('two')
;        ---> [1,2]
;
;       ;; How multiple entries are retrieved
;       print, ht->get('one', position=0)  ;; Returns first entry of this key
;        ---> 10
;       print, ht->get('one', position=1)  ;; Returns second entry of this key
;        ---> 1
;       
;       ;; Show number of keys in table
;       print, ht->keys()
;        ---> ['two','one','one','struct', 'hash']
;
;       ;; Destroy hash table
;       obj_destroy, ht
;       
;
; MODIFICATION HISTORY:
; 	Written and documented, Nov 2003, CM
;       Adjusted ::STRHASHVAL to accomodate possible overflow
;         exceptions, Apr 2004, CM
;       Enhanced ::STRHASHVAL to accept empty strings, 03 Jul 2006, CM
;         (thanks to William Dieckmann)
;       "Fixed" the empty-string problem yet again, 23 Oct 2006, CM
;         (thanks again to William Dieckmann)
;       Decrement COUNT variable after deleting keys, 09 Mar 2007, CM
;       Make ::REMOVE more efficient by using WHERE(COMPLEMENT=), 
;         12 Jun 2007, CM
;       Change array notation to square brackets and enforce with
;         compiler option, 15 Jun 2007, CM
;       Add user-defined "null" value for missing elements, 
;         15 Jun 2007, CM
;       Convert to [] array index notation, 20 Jun 2007, CM
;       Change the two WHERE's in ::REMOVE to a single WHERE
;         with COMPLEMENT, 20 Jun 2007, CM
;       Fix glaring bug in ::REMOVE when an entry still exists,
;         in a bucket, 27 Jun 2007, CM
;       Clean up the new NULL_VALUE pointer when destroying object,
;         (thanks to I. Zimine) 30 Jul 2007, CM
;       Fix case where user stores many identical keys (more than
;         LENGTH), 09 Aug 2007, CM
;       Add POSITION keyword to ::REMOVE, 12 Nov 2008, CM
;       Document the REPLACE keyword; correct COUNT() when replacing an
;        entry, 28 Jun 2009, CM
;       Add example documentation, 28 Jun 2009, CM
; 
;  $Id: hashtable__define.pro,v 1.13 2009/07/01 16:00:05 craigm Exp $
;-
; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::INIT
;
; PURPOSE:
;       Creates a hash table object.
;
; CALLING SEQUENCE:
;
;       result = obj_new('hashtable', [LENGTH=length,] [NULL_VALUE=null])
;
; DESCRIPTION:
;
;       The INIT method creates a new hash table object and
;       initializes it.  The user can chose the initial size of the
;       hashtable, which should be comparable to the number of entries
;       expected.
;
; OPTIONAL INPUTS:
;
;       None.
;
; KEYWORD PARAMETERS:
;
;       LENGTH - The number of "buckets" in the hash table, i.e. then
;                number of unique hash values.  This size is fixed
;                once the table is created, however since a bucket can
;                contain more than one entry, this is not a
;                fundamental limitation.
;
;       NO_DUPLICATES - If set, then duplicate entries are not allowed
;                       in the hash table.
;
;       NULL_VALUE - a custom "null" value which is returned when
;                    GET() does not find an entry.
;                    Default: 0L
;
; RETURNS:
;       A new hash table object.
;
; EXAMPLE:
;       ht = obj_new('hashtable')
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::CLEANUP
;
; PURPOSE:
;       De-allocates storage and cleans up a hash table object.
;
; CALLING SEQUENCE:
;
;       OBJ_DESTROY, ht
;       
; DESCRIPTION:
;
;       This procedure performs all clean-up required to remove the
;       object.  All hash table entries are freed.  However, if any of
;       the contained objects are heap data or objects, the user is
;       responsible for freeing those pointers or objects.
;
; OPTIONAL INPUTS:
;       None.
;       
;
; KEYWORD PARAMETERS:
;       None.
;       
;
; EXAMPLE:
;       OBJ_DESTROY, ht
;       
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::ADD
;
; PURPOSE:
;       Add an entry to a hash table.
;
; CALLING SEQUENCE:
;       HT->ADD, KEYNAME, VALUE, HASHVAL=HASHVAL, REPLACE=REPLACE
;         
;       
; DESCRIPTION:
;
;       This method adds a new hash association to an existing hash
;       table.  The hash table associates VALUE with the scalar string
;       KEYNAME.
;
; INPUTS:
;
;       KEYNAME - a scalar string which identifies the value.
;
; KEYWORD PARAMETERS:
;
;       HASHVAL - Use for performance.  If defined upon input,
;                 specifies the hash value for this KEYNAME.  If not
;                 defined upon input, the hash value is computed
;                 internally.  Upon output, the hash value used is
;                 returned in this variable.
;       REPLACE - If set, and if an entry with key KEYNAME already
;                 exists in the table, then replace it with VALUE.
;
; EXAMPLE:
;
;       HT->ADD, 'X', 1
;       HT->ADD, 'Y', 2
;       struct = {psym: 3, xtitle: 'Time', ytitle: 'Value'}
;       HT->ADD, 'extra', struct
;
;       Adds the ('X',1), ('Y',2) and ('extra', STRUCT) pairs to the
;       HT hash table.
;       
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
;       Document the REPLACE keyword, 28 Jun 2009, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::COUNT
;
; PURPOSE:
;       Returns number of entries in the hash table.
;       
;
; CALLING SEQUENCE:
;       CT = HT->COUNT()
;
; KEYWORD PARAMETERS:
;       None.
;
; RETURNS:
;       The number of entries.
;
; EXAMPLE:
;       CT = HT->COUNT()
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::REMOVE
;
; PURPOSE:
;       Removes a hash table entry from an existing hash table object.
;
; CALLING SEQUENCE:
;       HT->REMOVE, KEYNAME
;
; DESCRIPTION:
;
;       This method removes one or more hash entries from an existing
;       hash table.  Entries whose key matches KEYNAME are removed.
;
;       If KEYNAME does not exist, then REMOVE returns silently.
;
;       If multiple entries with the same KEYNAME exist, then they are
;       all deleted by default, unless the POSITION keyword is set.
;       After deleting some entries, positions of the remaining
;       entries may shift.
;
; INPUTS:
;       KEYNAME - a scalar string to be removed from the hash table.
;
; KEYWORD PARAMETERS:
;
;       HASHVAL - Use for performance.  If defined upon input,
;                 specifies the hash value for this KEYNAME.  If not
;                 defined upon input, the hash value is computed
;                 internally.  Upon output, the hash value used is
;                 returned in this variable.
;
;       COUNT - The number of hash entries removed.
;
;       POSITION - if more than one entry was found, then POSITION is
;                  a list of indices to delete (indices start at 0).
;                  IMPORTANT NOTE: out of bounds values are allowed,
;                  and will be rounded to in-bounds values.
;
; EXAMPLE:
;       HT->REMOVE, 'X'
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::ISCONTAINED
;
; PURPOSE:
;       Is a hash entry KEYNAME is contained by the hash table?
;
; CALLING SEQUENCE:
;       INSIDE = HT->ISCONTAINED(KEYNAME, COUNT=count, HASHVAL=HASHVAL,
;                                VALUE=value, POSITION=position)
;       
; DESCRIPTION:
;
;      This method determines whether a key is contained within the
;      hash table.  A return value of 1 indicates YES, 0 indicates NO.
;
;      If the key is found, then the value associated with that key
;      can be returned in the VALUE keyword.  If more than one entry
;      with the same key are found, then POSITION determines which
;      value is returned.
;      
; INPUTS:
;       KEYNAME - a scalar string, the key name to be searched for.
;
; KEYWORD PARAMETERS:
;
;       COUNT - upon return, the number of hash entries which match
;               KEYNAME.
;
;       VALUE - upon return, if KEYNAME was found, the value
;               associated with that key.  If more than one keys
;               match, then by default the first entry is returned,
;               unless POSITION is specified.  If the key is not
;               found, then VALUE is undefined.
;
;       POSITION - if KEYNAME was found, and more than one entry was
;                  found, then the POSITION'th entry is returned in
;                  VALUE (the index starts at 0).
;
;       HASHVAL - Use for performance.  If defined upon input,
;                 specifies the hash value for this KEYNAME.  If not
;                 defined upon input, the hash value is computed
;                 internally.  Upon output, the hash value used is
;                 returned in this variable.
;
; RETURNS:
;       Is the key contained within the table?  (Scalar integer:
;          1=YES, 0=NO)
;       
; EXAMPLE:
;       if HT->ISCONTAINED('X') EQ 1 then print, 'X found'
;
;       if HT->ISCONTAINED('X', VALUE=xvalue) then begin
;           oplot, xvalue
;       endif
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::GET
;
; PURPOSE:
;       Retrieves a value associated with a key from the hash table.
;       
;
; CALLING SEQUENCE:
;       VALUE = HT->GET('X', COUNT=count, POSITION=position, HASHVAL=hashval)
;       
; DESCRIPTION:
;
;       This method searches for the requested key in the hash table,
;       and returns the value associated with that key.
;
;       If more than one entry with the same key are found, then
;       POSITION determines which value is returned.
;
;       If the key is not found, then COUNT is set to zero, and the
;       returned value is undefined.
;
;
; KEYWORD PARAMETERS:
;
;       COUNT - upon return, the number of hash entries which match
;               KEYNAME.
;
;       POSITION - if KEYNAME was found, and more than one entry was
;                  found, then the POSITION'th entry is returned in
;                  VALUE (the index starts at 0).
;
;                  WARNING: if the hash table has been changed using
;                  ADD or REMOVE, then the order of elements in the
;                  table may shift.
;
;       HASHVAL - Use for performance.  If defined upon input,
;                 specifies the hash value for this KEYNAME.  If not
;                 defined upon input, the hash value is computed
;                 internally.  Upon output, the hash value used is
;                 returned in this variable.
;
; OUTPUTS:
;
;       The value associated with KEYNAME is returned.  If KEYNAME was
;       not found, then COUNT is zero and the return value is
;       set to the "null" value (see ::INIT).
;       
;
; EXAMPLE:
;
;       X = HT->GET('X')
;       
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::KEYS
;
; PURPOSE:
;       Retrieves all the keys of the hash tables
;       
;
; CALLING SEQUENCE:
;       KEYS = HT->KEYS()
;       
; DESCRIPTION:
;
;       This method returns all of the keys in the hash table.  If
;       duplicate hash entries are present, then a key may appear more
;       than once.
;
;       The order of the keys is undefined.
;
; KEYWORD PARAMETERS:
;       None.
;
; RETURNS:
;
;       A string array containing the keys of this hash table.
;       If the table is empty, then COUNT will be set to zero,
;       and a scalar string '' is returned.
;
; EXAMPLE:
;
;       KEYS = HT->KEYS()
;       for i = 0, n_elements(keys)-1 do print, ht->get(keys(i))
;       
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
;+
; =============================================================
;
; METHODNAME:
;       HASHTABLE::STRUCT
;
; PURPOSE:
;       Converts the hash table to an equivalent IDL structure
;       
;
; CALLING SEQUENCE:
;       STRUCT = HT->STRUCT()
;       
; DESCRIPTION:
;
;       This method converts the hash table into an equivalent IDL
;       structure.  One structure tag appears for each hash entry.
;
;       WARNING: (1) the hash keys must be valid IDL structure names;
;       (2) there must be no duplicate keys in the hash table.
;
;       The order of the keys is undefined.
;
; KEYWORD PARAMETERS:
;       None.
;
; RETURNS:
;
;       A structure.
;
; EXAMPLE:
;
;       HTSTRUCT = HT->STRUCT()
;       help, keys, htstruct
;       
;
; MODIFICATION HISTORY:
;       Written and documented, Nov 2003, CM
; 	
;-
; =============================================================
; METHODNAME: HASHTABLE__DEFINE
;  internal method: defines hash table data structure
pro hashtable__define

  COMPILE_OPT strictarr
  struct = {hashtable, $
            table: ptr_new(), $  ;; Table of HASHENT structures
            length: 0L, $        ;; Number of buckets in table
            count: 0L, $         ;; Number of entries in table
            flags: 0L, $         ;; Flags
            free_keys: 0L, $
            free_values: 0L, $
            null_value: ptr_new() $
           }
  return
end


;+
; NAME:
;   HELPFORM
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Generate a descriptive string in IDL HELP format
;
; CALLING SEQUENCE:
;   STRINGS = HELPFORM(NAME, VALUE, [/SHORTFORM,] [/SINGLE,] [WIDTH=width])
;
; DESCRIPTION: 
;
;   The HELPFORM function converts an IDL data value into a
;   representation very similar to the format produced by the built-in
;   command HELP.  Programmers can thus present data types and values
;   to users in a format they are familiar with.
;
;   For example, if the variable A is defined in the following manner,
;   and HELP is called, then the following transcript will result:
;
;     IDL> a = [1,2]
;     IDL> help, a
;     A               INT       = Array[2]
;
;   The same result can be achieved with the HELPFORM function:
;
;     IDL> print, helpform('A', a)
;     A               INT       = Array[2]
;
;   The benefit is that the output of HELPFORM is a string that can be
;   outputted or reformatted.  This capability is not available in all
;   versions of IDL.
;
;   HELPFORM actually produces *two* forms of output.  The above
;   output is considered the "long" form, as it appears in the IDL
;   HELP command, and is the default.  A "short" form can also be
;   produced, and is very similar to the information that appears in
;   certain terse IDL error messages.  It is activated by setting the
;   SHORTFORM keyword.
;
;   If the variable name is too long, the HELPFORM may be forced to be
;   two lines long to have consistent formatting.  In that case a
;   two-element string is returned.  If a single line is desired, use
;   the SINGLE keyword, but this comes at the expense of consistent
;   output formatting.
;
; INPUTS:
;
;   NAME - A scalar string containing the name of the IDL variable.
;          An empty string is permitted.  The name is ignored if the
;          SHORTFORM keyword is set.
;
;   VALUE - Any IDL value to be examined.  VALUE is optional if the
;           SIZE keyword is passed and uniquely describes the data.
;           VALUE should be passed for scalars and structures, since
;           the help form for these values requires additional
;           information beyond the SIZE.
;
; KEYWORDS:
;
;   SIZE - the IDL SIZE descriptor for the value to be printed.
;          Default: information is taken from VALUE.
;
;   SINGLE - if set, then output which would normally
;            appear on two lines for consistent formatting, appears on
;            one single line instead.
;
;   FULL_STRUCT - if set, then a detailed output is printed for
;                 structures, similar to HELP, VALUE, /STRUCTURE.
;

;   RECURSIVE_STRUCT - if both this keyword and FULL_STRUCT are set,
;                      and if VALUE itself has sub-structures, then
;                      print the full contents of those sub-structures
;                      as well.  The contents will be slightly indented.
;
;   SHORTFORM - set this keyword for a shorter output format that can
;               be used in error messages.
;
;   WIDTH - the width of the terminal in characters (used for
;           formatting).
;           Default: 80
;
; RETURNS:
;
;   An array of strings containing the HELPFORM output, which may have
;   more than one element depending on the length of NAME, SHORTFORM
;   and SINGLE.  The helpforms of pointer- and object-typed values
;   does not include the sequence number, but are otherwise correct.
;
; EXAMPLE:
;
;     IDL> print, helpform('A', size=[1,2,1,2])
;     A               BYTE      = Array[2]
;     ;; Do not pass VALUE and instead use SIZE to specify the type
;
;     IDL> print, helpform('A', size=[1,2,1,2], /shortform)
;     BYTE     (Array[2])
;     ;; Compare to the short form, which is meant to be placed in
;     ;; error messages
;
;     IDL> print, helpform('fjsldkfjsldfkjslkdfjslkdfjslkdfjsldkfjk',a)
;     fjsldkfjsldfkjslkdfjslkdfjslkdfjsldkfjk
;                      INT       = Array[2]
;     IDL> print, helpform('fjsldkfjsldfkjslkdfjslkdfjslkdfjsldkfjk',a,/single)
;     fjsldkfjsldfkjslkdfjslkdfjslkdfjsldkfjk INT       = Array[2]
;     ;; Compare the long and short forms
;
;
; SEE ALSO:
;
;   INPUTFORM, HELP
;
; MODIFICATION HISTORY:
;   Written, CM, 13 May 2000
;   Documented, 04 Jul 2000
;   Improved output for objects, CM, 11 Jan 2001
;   Added support for full structure output, CM 08 Feb 2001
;   Added forward_function declaration for safety, CM 08 Apr 2001
;   Print more info about POINTER type, CM 08 Apr 2001
;   Add the RECURSIVE_STRUCT keyword, CM 04 Jan 2009
;
; $Id: helpform.pro,v 1.6 2009/01/04 09:18:18 craigm Exp $
;
;-
; Copyright (C) 2000-2001, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   HPRNUTANG
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Compute high precision earth precession, nutation and orientation angles
;
; MAJOR TOPICS:
;   Geometry
;
; CALLING SEQUENCE:
;   HPRNUTANG, JDTT, ZETA, THETA, Z, DPSI, DEPS, $
;              POLAR_X=PMX, POLAR_Y=PMY, JD_UT1=JD_UT1, /USE_EOPDATA, $
;              TBASE=, FIXED_EPOCH=, FIXED_BASE=, $
;              /JPL, /NO_UT1, $
;              MEAN_OBLIQUITY=EPS0, TRUE_OBLIQUITY=EPS, $
;              GMS_TIME=GMST, GAS_TIME=GAST, EQ_EQUIONOX=EQEQ
;              
;
; DESCRIPTION:
;
;  The procedure HPRNUTANG computes values of the earth
;  orientation-related angles, including precession and nutation,
;  which are used for high precision earth-based astronomy
;  applications.  
;
;  It is the goal of this procedure to provide all angles relevant in
;  determining the position of an earth station, as measured in an
;  earth-fixed coordinate system, and converting to space-fixed
;  coordinates.  This is useful in applications where observations by
;  a station in the earth-fixed frame are taken of an astrophysical
;  object which is in the non-rotating space-fixed frame.
;
;  This routine potentially depends on the following external
;  procedures, which also themselves depend on external data files:
;
;      EOPDATA - estimates Earth orientation parameters (if
;                USE_EOPDATA keyword is set), depends on earth
;                orientation data file.
;      TAI_UTC - computes time difference TAI - UTC (leap seconds),
;                depends on leap seconds file.
;
;  This interface is somewhat provisional.  See OPEN QUESTIONS below.
;
;  The user requests the quantities for a particular set of epoch
;  times, as measured in Julian days, in the system of Terrestrial
;  Dynamical Time ( = TDT = TT ).  
;
;  HPRNUTANG returns several quantities.  It is not possible to
;  describe each of these quantities in full detail in this
;  documentation.  The user is referred to the Explanatory Supplement
;  to the Astronomical Almanac (Sec 3.2) for more complete
;  descriptions.  The quantities are:
;
;    * ZETA, THETA, Z, which are euler angles representing the
;      precession of the mean celestial ephemeris pole with respect to
;      the space-fixed coordinate system defined by the FIXED epoch.
;      For a vector R_MEAN_OFDATE, whose space-fixed coordinates are
;      referred to the mean pole of date, the transformation to
;      space-fixed coordinates referred to the mean pole of the fixed
;      epoch is:
;
;        R_FIXED = qtvrot(R_MEAN_OFDATE, $
;                        qteuler(['z','y','z'], -zeta, +theta, -z))
;
;      By default the "fixed" epoch is J2000.0.  [ See below for
;      definitions of QTVROT and QTEULER. ]
;
;    * DPSI, DEPS, which are the angles representing the nutation in
;      longitude and obliquity of the true of-date celestial ephemeris
;      pole with respect to the mean pole of date.  For a vector
;      R_TRUE_OFDATE, whose space-fixed coordinates are referred to
;      the true pole of date, the transformation to space-fixed
;      coordinates referred to the mean pole of date is:
;
;        R_MEAN_OFDATE = qtvrot(R_TRUE_OFDATE, $
;                              qteuler(['x','z','x'], $
;                                      +eps0, -dpsi, -eps0-deps)
;
;      where EPS and EPS0 are defined below.
;
;    * EPS0, which is the mean obliquity of the ecliptic plane,
;      referred to the mean equator of date, at the requested epoch.
;      For a vector, R_ECL_OFDATE, whose space-fixed coordinates are
;      referred to the mean ecliptic and equinox of date, the
;      transformation to space-fixed coordinates referred to the mean
;      equator and equinox of date is:
;
;        R_MEAN_OFDATE = qtvrot(R_ECL_OFDATE, $
;                               qteuler(['x'], eps0)
;
;    * EPS, which is the true obliquity of the ecliptic plane,
;      referred to the mean equator of date, at the requested epoch.
;
;    * GMST, GAST, which are the mean and apparent Greenwich Sidereal
;      Times at the requested epoch.  For a vector R_TRUE_EARTHFIXED,
;      whose earth-fixed coordinates are referred to the true pole of
;      date, the transformation to space-fixed coordinates referred to
;      the true pole of date are:
;
;        R_TRUE_OFDATE = qtvrot(R_TRUE_EARTHFIXED, $
;                              qteuler(['z'], +gast))
;
;    * EQEQ, the equation of the equinoxes at the requested epoch.
;      This quantity may be more commonly known as the "precession of
;      the equinox."
;
;    * PMX, PMY, the coordinates of the celestial ephemeris pole as
;      measured in the earth-fixed coordinate system (set to zero if
;      the USE_EOPDATA keyword is not set).  For a vector
;      R_MEAN_EARTHFIXED, whose earth-fixed coordinates are referred
;      to the International Reference Pole, the transformation to
;      earth-fixed coordinates referred to the true pole of date are:
;
;        R_TRUE_EARTHFIXED = qtvrot(R_MEAN_EARTHFIXED, $
;                                  qteuler(['x','y'], -pmy, -pmx))
;
;      The vector R_MEAN_EARTHFIXED, could be for example, the
;      cartesian coordinates of a station on the earth, as determined
;      from its geodetic/geocentric latitude and longitude.
;
;    * JD_UT1, the UT1 time (expressed in Julian days) (set to UTC if
;      the USE_EOPDATA keyword is not set or if NO_UT1 is set).
;
;  Users may select different techniques to compute some of these
;  quantities.  See keywords JPL and USE_EOPDATA.
;
;
; OPEN QUESTIONS
;
;   How will the transition to a new IERS EOP series be accomplished?
;   Using a keyword?  How can users select different nutation series?
;   How can users select different fundamental arguments for the
;   planets.
;
;
; VERIFICATION
;
;   The precession and nutation quantities were compared against those
;   produced by the SLALIB telescope pointing library.  
;
;   For the epoch JD 2450449 (TT), the precession quantities of
;   HPRNUTANG agree numerically with SLALIB SLA_PREC to within 0.1
;   microarcseconds, and the nutation quantities agree SLALIB SLA_NUTC
;   to within 6 microarcseconds (and 54 microarcseconds in the mean
;   obliquity).  The GMST values agree with SLALIB SLA_GMSTA to better
;   than 1 nanosecond.  Of course this says nothing about the accuracy
;   of the IAU 1976/1980 precession and nutation models with respect
;   to the true precession and nutations.
;
;   The precession and nutation quantities computed in this procedure
;   -- ZETA, THETA, Z, DPSI and DEPS -- were also used to compute the
;   space-fixed coordinates of the Goldstone DSS-63 deep space network
;   tracking station.  These values were compared against values
;   produced by JPL Horizons ephemeris generator.  Agreement was found
;   at the 60 cm level.  Accuracy at that level is probably limited by
;   the JPL DE406 earth ephemeris used by Horizons.
;
;   Polar motion values were estimated at the same epoch using
;   EOPDATA, and applied to three orthogonal unit vectors.  The above
;   quaternion transformation produces the same coordinate values,
;   when compared against SLALIB_POLMO.
;
;
; QTEULER and QTVROT
;
;   The functions QTEULER and QTVROT are functions from the Markwardt
;   quaternion library.  QTEULER composes a chain of Euler-like
;   rotations into a single quaternion.  QTVROT applies a quaternion
;   rotation to a 3-vector.
;
;   The user need not use these functions.  Any function which
;   constructs a set of Euler-like rotations, and then applies them to
;   3-vectors will work fine.
;
;
; INPUTS:
;
;   JDTT - a vector or scalar, the TT epoch time(s) for which high
;          precision values are to be computed.
;
;          For reference, JDTT = JDTAI + 32.184/86400d, where JDTAI is
;          the international atomic time measured in days.  The value
;          of the keyword TBASE is added to JDTT to arrive at the
;          actual Julian date.
;
; OUTPUTS:
;
;   ZETA, THETA, Z - Euler angles of precession of the mean celestial
;                    ephemeris pole, expressed in ANGUNITS units.
;
;   DPSI, DEPS - the nutation angles in longitude and obliquity of the
;                true pole with respect to the mean pole, expressed in
;                ANGUNITS units.  By default the values are based on
;                the IAU 1980 theory of nutation.  The user can select
;                JPL to interpolate the JPL nutation ephemerides.
;
;                When USE_EOPDATA is set, the nutation angles are
;                augmented by the offset correction terms supplied in
;                the EOP file.
;
; KEYWORD PARAMETERS:
;
;   TBASE - scalar or vector, a fixed epoch time (Julian days) to be
;           added to each value of JDTT.  Since subtraction of large
;           numbers occurs with TBASE first, the greatest precision is
;           achieved when TBASE is expressed as a nearby julian epoch,
;           JDTT is expressed as a small offset from the fixed epoch.
;           Default: 0
;
;   FIXED_EPOCH - a scalar or vector number, the fixed epoch (in TT
;                 Julian Days) against which the precession angles of
;                 the mean pole are referred.  
;                 Default: JD 2451545.0 TT ( = J2000.0 )
;
;   FIXED_BASE - scalar or vector, a fixed epoch time to be added to
;                FIXED_EPOCH, in much the same way that TBASE is added
;                to JDTT.  Default: 0
;
;   POLAR_X, POLAR_Y - upon return, the quantities PMX and PMY, in
;                      ANGUNITS units, if USE_EOPDATA is set.  If
;                      USE_EOPDATA is not set then zero is returned
;                      for both PMX and PMY.
;
;   JD_UT1 - upon return, the time in the UT1 system at the requested
;            epoch, if the USE_EOPDATA keyword is set.  If the
;            USE_EOPDATA keyword is not set, or if NO_UT1 is set, then
;            the time in UTC is returned (which is guaranteed to be
;            within +/- 0.9 seconds of UT1).
;
;   MEAN_OBLIQUITY - upon return, the quantity EPS0, in ANGUNITS
;                    units.
;
;   TRUE_OBLIQUITY - upon return, the quantity EPS, in ANGUNITS units.
;
;   GMS_TIME - upon return, the quantity GMST in radians.
;
;   GAS_TIME - upon return, the quantity GAST in radians.
;
;   EQ_EQUINOX - upon return, the quantity EQEQ in ANGUNITS units.
;
;   ANGUNITS - scalar string, output units of angular parameters.
;              Possible values are 'ARCSEC' or 'RADIAN'.
;              Default value: 'RADIAN'
;
;   JPL - a scalar integer or string.  If JPL is defined, then the routine
;         attempts to use the JPL nutation ephemeris to determine the
;         nutation angle quantities.  If JPL is a scalar string, then
;         it is interpreted as the FITS file name to use (see
;         JPLEPHREAD).  If JPL=1, the JPL ephemeris FITS file must be
;         present in
;             $ASTRO_DATA/JPLEPH.405
;         where ASTRO_DATA is the standard environment variable for
;         data used by the IDL Astronomy Library.  
;         Default: not set (i.e. do not use JPL ephemeris nutation quantities)
;
;   NO_UT1 - if set, then do not compute UT1, but use UTC instead.
;
;   USE_EOPDATA - if set, use the EOPDATA procedure to determine earth
;                 orientation parameters at the requested epoch.
;                 These include polar motion values, corrections to
;                 the 1980 IAU nutation theory, and the UT1
;                 correction.
;
;
; EXAMPLE:
;
;   Need an example converting topocentric to/from J2000.0
;
;   Need an example converting station position earth-fixed
;   coordinates to/from space-fixed coordinates.
;
;
;
; SEE ALSO:
;
;   HPRNUTANG, TAI_UTC (Markwardt Library)
;   PRECESS, NUTATE, PREMAT, JPRECESS, BPRECESS (IDL Astronomy Library)
;
;
; REFERENCES:
;
;   Aoki, S., Guinot, B., Kaplan, G.H., Kinoshita, H., McCarthy, D.D.,
;     Seidelmann, P.K., 1982: Astron. Astrophys., 105, 359-361.
;
;   HORIZONS, JPL Web-based ephemeris calculator (Ephemeris DE406)
;      http://ssd.jpl.nasa.gov/horizons.html
;
;   McCarthy, D. D. (ed.) 1996: IERS Conventions, IERS T.N. 21.
;     http://maia.usno.navy.mil/conventions.html
;
;   Seidelmann, P.K. 1992, *Explanatory Supplement to the Astronomical
;     Almanac*, ISBN 0-935702-68-7
;
;
; MODIFICATION HISTORY:
;   Written, 30 Jan 2002, CM
;   Documented, 15 Feb 2002, CM
;   Added docs about ecliptic; added default of 'RADIAN' to code; 01
;     Mar 2002, CM
;   Corrected equation of equinoxes (had DPSI*COS(EPS0), when it
;     should be DPSI*COS(EPS)), 01 Mar 2002, CM
;   Added default message, 04 Mar 2002, CM
;   Added more logic to detect JPL ephemeris file, 17 Mar 2002, CM
;   Corrected discussion of geodetic coordinates, 26 May 2002, CM
;   Documentation tweaks, 05 Jan 2004, CM
;   Some modifications to conserve memory, 22 Dec 2008, CM
;   Allow TBASE/FBASE to be a vector, 01 Jan 2009, CM
;   Documentation of the JPL parameter, 02 Dec 2009, CM
;
;  $Id: hprnutang.pro,v 1.17 2009/12/03 02:08:46 craigm Exp $
;
;-
; Copyright (C) 2002, 2004, 2008, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; IAU 1980 Nutation Model
;   * taken from http://hpiers.obspm.fr/eop-pc/models/nut_iau1980
iau_1980_nut_strs = [ $
;  # Fortran format : (5I3,8X,6F10.1) 
;  #  Delaunay Arg. period(days)  
;  # lm ls F  D Om            psisin     t sin    eps cos     t cos
;   0    .    10   .    20        30        40        50         60     
   '  0  0  0  0  1 -6798.4 -171996.0    -174.2   92025.0       8.9     ', $
   '  0  0  2 -2  2   182.6  -13187.0      -1.6    5736.0      -3.1     ', $
   '  0  0  2  0  2    13.7   -2274.0      -0.2     977.0      -0.5     ', $
   '  0  0  0  0  2 -3399.2    2062.0       0.2    -895.0       0.5     ', $
   '  0 -1  0  0  0  -365.3   -1426.0       3.4      54.0      -0.1     ', $
   '  1  0  0  0  0    27.6     712.0       0.1      -7.0       0.0     ', $
   '  0  1  2 -2  2   121.7    -517.0       1.2     224.0      -0.6     ', $
   '  0  0  2  0  1    13.6    -386.0      -0.4     200.0       0.0     ', $
   '  1  0  2  0  2     9.1    -301.0       0.0     129.0      -0.1     ', $
   '  0 -1  2 -2  2   365.2     217.0      -0.5     -95.0       0.3     ', $
   ' -1  0  0  2  0    31.8     158.0       0.0      -1.0       0.0     ', $
   '  0  0  2 -2  1   177.8     129.0       0.1     -70.0       0.0     ', $
   ' -1  0  2  0  2    27.1     123.0       0.0     -53.0       0.0     ', $
   '  1  0  0  0  1    27.7      63.0       0.1     -33.0       0.0     ', $
   '  0  0  0  2  0    14.8      63.0       0.0      -2.0       0.0     ', $
   ' -1  0  2  2  2     9.6     -59.0       0.0      26.0       0.0     ', $
   ' -1  0  0  0  1   -27.4     -58.0      -0.1      32.0       0.0     ', $
   '  1  0  2  0  1     9.1     -51.0       0.0      27.0       0.0     ', $
   ' -2  0  0  2  0  -205.9     -48.0       0.0       1.0       0.0     ', $
   ' -2  0  2  0  1  1305.5      46.0       0.0     -24.0       0.0     ', $
   '  0  0  2  2  2     7.1     -38.0       0.0      16.0       0.0     ', $
   '  2  0  2  0  2     6.9     -31.0       0.0      13.0       0.0     ', $
   '  2  0  0  0  0    13.8      29.0       0.0      -1.0       0.0     ', $
   '  1  0  2 -2  2    23.9      29.0       0.0     -12.0       0.0     ', $
   '  0  0  2  0  0    13.6      26.0       0.0      -1.0       0.0     ', $
   '  0  0  2 -2  0   173.3     -22.0       0.0       0.0       0.0     ', $
   ' -1  0  2  0  1    27.0      21.0       0.0     -10.0       0.0     ', $
   '  0  2  0  0  0   182.6      17.0      -0.1       0.0       0.0     ', $
   '  0  2  2 -2  2    91.3     -16.0       0.1       7.0       0.0     ', $
   ' -1  0  0  2  1    32.0      16.0       0.0      -8.0       0.0     ', $
   '  0  1  0  0  1   386.0     -15.0       0.0       9.0       0.0     ', $
   '  1  0  0 -2  1   -31.7     -13.0       0.0       7.0       0.0     ', $
   '  0 -1  0  0  1  -346.6     -12.0       0.0       6.0       0.0     ', $
   '  2  0 -2  0  0 -1095.2      11.0       0.0       0.0       0.0     ', $
   ' -1  0  2  2  1     9.5     -10.0       0.0       5.0       0.0     '  ]
iau_1980_nut_strs = [ iau_1980_nut_strs, $
   '  1  0  2  2  2     5.6      -8.0       0.0       3.0       0.0     ', $
   '  0 -1  2  0  2    14.2      -7.0       0.0       3.0       0.0     ', $
   '  0  0  2  2  1     7.1      -7.0       0.0       3.0       0.0     ', $
   '  1  1  0 -2  0   -34.8      -7.0       0.0       0.0       0.0     ', $
   '  0  1  2  0  2    13.2       7.0       0.0      -3.0       0.0     ', $
   ' -2  0  0  2  1  -199.8      -6.0       0.0       3.0       0.0     ', $
   '  0  0  0  2  1    14.8      -6.0       0.0       3.0       0.0     ', $
   '  2  0  2 -2  2    12.8       6.0       0.0      -3.0       0.0     ', $
   '  1  0  0  2  0     9.6       6.0       0.0       0.0       0.0     ', $
   '  1  0  2 -2  1    23.9       6.0       0.0      -3.0       0.0     ', $
   '  0  0  0 -2  1   -14.7      -5.0       0.0       3.0       0.0     ', $
   '  0 -1  2 -2  1   346.6      -5.0       0.0       3.0       0.0     ', $
   '  2  0  2  0  1     6.9      -5.0       0.0       3.0       0.0     ', $
   '  1 -1  0  0  0    29.8       5.0       0.0       0.0       0.0     ', $
   '  1  0  0 -1  0   411.8      -4.0       0.0       0.0       0.0     ', $
   '  0  0  0  1  0    29.5      -4.0       0.0       0.0       0.0     ', $
   '  0  1  0 -2  0   -15.4      -4.0       0.0       0.0       0.0     ', $
   '  1  0 -2  0  0   -26.9       4.0       0.0       0.0       0.0     ', $
   '  2  0  0 -2  1   212.3       4.0       0.0      -2.0       0.0     ', $
   '  0  1  2 -2  1   119.6       4.0       0.0      -2.0       0.0     ', $
   '  1  1  0  0  0    25.6      -3.0       0.0       0.0       0.0     ', $
   '  1 -1  0 -1  0 -3232.9      -3.0       0.0       0.0       0.0     ', $
   ' -1 -1  2  2  2     9.8      -3.0       0.0       1.0       0.0     ', $
   '  0 -1  2  2  2     7.2      -3.0       0.0       1.0       0.0     ', $
   '  1 -1  2  0  2     9.4      -3.0       0.0       1.0       0.0     ', $
   '  3  0  2  0  2     5.5      -3.0       0.0       1.0       0.0     ', $
   ' -2  0  2  0  2  1615.7      -3.0       0.0       1.0       0.0     ', $
   '  1  0  2  0  0     9.1       3.0       0.0       0.0       0.0     ', $
   ' -1  0  2  4  2     5.8      -2.0       0.0       1.0       0.0     ', $
   '  1  0  0  0  2    27.8      -2.0       0.0       1.0       0.0     ', $
   ' -1  0  2 -2  1   -32.6      -2.0       0.0       1.0       0.0     ', $
   '  0 -2  2 -2  1  6786.3      -2.0       0.0       1.0       0.0     ', $
   ' -2  0  0  0  1   -13.7      -2.0       0.0       1.0       0.0     ', $
   '  2  0  0  0  1    13.8       2.0       0.0      -1.0       0.0     ', $
   '  3  0  0  0  0     9.2       2.0       0.0       0.0       0.0     ', $
   '  1  1  2  0  2     8.9       2.0       0.0      -1.0       0.0     ', $
   '  0  0  2  1  2     9.3       2.0       0.0      -1.0       0.0     ', $
   '  1  0  0  2  1     9.6      -1.0       0.0       0.0       0.0     ', $
   '  1  0  2  2  1     5.6      -1.0       0.0       1.0       0.0     ', $
   '  1  1  0 -2  1   -34.7      -1.0       0.0       0.0       0.0     ', $
   '  0  1  0  2  0    14.2      -1.0       0.0       0.0       0.0     ', $
   '  0  1  2 -2  0   117.5      -1.0       0.0       0.0       0.0     ', $
   '  0  1 -2  2  0  -329.8      -1.0       0.0       0.0       0.0     ', $
   '  1  0 -2  2  0    23.8      -1.0       0.0       0.0       0.0     ', $
   '  1  0 -2 -2  0    -9.5      -1.0       0.0       0.0       0.0     ', $
   '  1  0  2 -2  0    32.8      -1.0       0.0       0.0       0.0     ', $
   '  1  0  0 -4  0   -10.1      -1.0       0.0       0.0       0.0     ', $
   '  2  0  0 -4  0   -15.9      -1.0       0.0       0.0       0.0     ', $
   '  0  0  2  4  2     4.8      -1.0       0.0       0.0       0.0     ', $
   '  0  0  2 -1  2    25.4      -1.0       0.0       0.0       0.0     ', $
   ' -2  0  2  4  2     7.3      -1.0       0.0       1.0       0.0     ', $
   '  2  0  2  2  2     4.7      -1.0       0.0       0.0       0.0     ', $
   '  0 -1  2  0  1    14.2      -1.0       0.0       0.0       0.0     ', $
   '  0  0 -2  0  1   -13.6      -1.0       0.0       0.0       0.0     ', $
   '  0  0  4 -2  2    12.7       1.0       0.0       0.0       0.0     ', $
   '  0  1  0  0  2   409.2       1.0       0.0       0.0       0.0     ', $
   '  1  1  2 -2  2    22.5       1.0       0.0      -1.0       0.0     ', $
   '  3  0  2 -2  2     8.7       1.0       0.0       0.0       0.0     ', $
   ' -2  0  2  2  2    14.6       1.0       0.0      -1.0       0.0     ', $
   ' -1  0  0  0  2   -27.3       1.0       0.0      -1.0       0.0     ', $
   '  0  0 -2  2  1  -169.0       1.0       0.0       0.0       0.0     ', $
   '  0  1  2  0  1    13.1       1.0       0.0       0.0       0.0     ', $
   ' -1  0  4  0  2     9.1       1.0       0.0       0.0       0.0     ', $
   '  2  1  0 -2  0   131.7       1.0       0.0       0.0       0.0     ', $
   '  2  0  0  2  0     7.1       1.0       0.0       0.0       0.0     ', $
   '  2  0  2 -2  1    12.8       1.0       0.0      -1.0       0.0     ', $
   '  2  0 -2  0  1  -943.2       1.0       0.0       0.0       0.0     ', $
   '  1 -1  0 -2  0   -29.3       1.0       0.0       0.0       0.0     ', $
   ' -1  0  0  1  1  -388.3       1.0       0.0       0.0       0.0     ', $
   ' -1 -1  0  2  1    35.0       1.0       0.0       0.0       0.0     ', $
   '  0  1  0  1  0    27.3       1.0       0.0       0.0       0.0     ' ]

  n80 = n_elements(iau_1980_nut_strs)

  argfacts = fltarr(5,n80)
  str = strmid(iau_1980_nut_strs,0,16)
  reads, str, argfacts
  argfacts = transpose(argfacts)

  psiamps = dblarr(2,n80)
  str = strmid(iau_1980_nut_strs,23,21)
  reads, str, psiamps
  psiamps = transpose(psiamps)

  epsamps = fltarr(2,n80)
  str = strmid(iau_1980_nut_strs,43,20)
  reads, str, epsamps
  epsamps = transpose(epsamps)

  return
end

pro hprnutang_init_iau1980_args, args
  ;; c1 = mean anomaly of Moon
  ;; c2 = mean anomaly of Sun
  ;; c3 = mean longitude of the Moon minus the mean longitude of Moon's node
  ;; c4 = mean elongation of Moon from Sun
  ;; c5 = mean longitude of ascending node of the Moon
  ;; c6 = mean anomaly of Mercury
  ;; c7 = mean anomaly of Venus
  ;; c8 = mean anomaly of Earth
  ;; c9 = mean anomaly of Mars
  ;; ca = mean anomaly of Jupiter
  ;; cb = mean anomaly of Saturn

  c1 = [134.96298139d*3600d, 1717915922.6330d,  31.310d,   0.064d]
  c2 = [357.52772333d*3600d,  129596581.2240d,  -0.577d,  -0.012d]
  c3 = [ 93.27191028d*3600d, 1739527263.1370d, -13.257d,   0.011d]
  c4 = [297.85036306d*3600d, 1602961601.3280d,  -6.891d,   0.019d]
  c5 = [125.04452222d*3600d,   -6962890.5390d,   7.455d,   0.008d]
  c6 = [252.3d       *3600d,     149472.7d,      0d,       0d    ]
  c7 = [179.9d       *3600d,      58517.8d,      0d,       0d    ]
  c8 = [ 98.4d       *3600d,      35999.4d,      0d,       0d    ]
  c9 = [353.3d       *3600d,      19140.3d,      0d,       0d    ]
  ca = [ 32.3        *3600d,       3034.9d,      0d,       0d    ]
  cb = [ 48.0        *3600d,       1222.1d,      0d,       0d    ]

  args = [[c1],[c2],[c3],[c4],[c5],[c6],[c7],[c8],[c9],[ca],[cb]]
  args = args * !dpi / 180d / 3600d

  return
end

pro hprnutang_init_iau1996_args, args
  ;; c1 = mean anomaly of Moon
  ;; c2 = mean anomaly of Sun
  ;; c3 = mean longitude of the Moon minus the mean longitude of Moon's node
  ;; c4 = mean elongation of Moon from Sun
  ;; c5 = mean longitude of ascending node of the Moon
  ;; c6 = mean anomaly of Mercury
  ;; c7 = mean anomaly of Venus
  ;; c8 = mean anomaly of Earth
  ;; c9 = mean anomaly of Mars
  ;; ca = mean anomaly of Jupiter
  ;; cb = mean anomaly of Saturn
  ;; cc = accumulated general precession
  
  c1= [134.96340251d*3600d, 1717915923.2178d,  31.8792d,  5.1635d-2, 2.4470d-4]
  c2= [357.52910918d*3600d,  129596581.0481d,  -0.5532d,  1.36d-4,  -1.149d-5]
  c3= [ 93.27209062d*3600d, 1739527262.8478d, -12.7512d, -1.037d-3,  4.17d-6]
  c4= [297.85019547d*3600d, 1602961601.2090d,  -6.3706d,  6.593d-3, -3.169d-5]
  c5= [125.04455501d*3600d,   -6962890.2665d,   7.4722d,  7.702d-3, -5.939d-5]
  c6= [  0d,                     0d,                 0d,  0d,        0d      ]
  c7= [181.979800853d*3600d, 58517.8156748d*3600d,   0d,  0d,        0d      ]
  c8= [100.466448494d*3600d, 35999.3728521d*3600d,   0d,  0d,        0d      ]
  c9= [355.433274605d*3600d, 19140.299314d *3600d,   0d,  0d,        0d      ]
  ca= [ 34.351483900d*3600d,  3034.90567464d*3600d,  0d,  0d,        0d      ]
  cb= [ 50.0774713998d*3600d, 1222.11379404d*3600d,  0d,  0d,        0d      ]
  cc= [  0d,                  1.39697137214d*3600d,  3.086d-4, 0d,  0d       ]

  args = [[c1],[c2],[c3],[c4],[c5],[c6],[c7],[c8],[c9],[ca],[cb],[cc]]
  args = args * !dpi / 180d / 3600d

  return
end

pro hprnutang, jdtt, zeta, theta, z, dpsi, deps, jpl=jpl, $
               tbase=tbase0, polar_x=pmx, polar_y=pmy, $
               fixed_epoch=fepoch0, fixed_base=fbase0, $
               jd_ut1=jdut1, mean_obliquity=eps0, true_obliquity=eps, $
               gms_time=gmst, gas_time=gast, eq_equinox=eqeq, $
               use_eopdata=useeop, no_ut1=no_ut1, no_nutation=no_nut1

  common hprnutang_iau80_coeffs, arg80, psi80, eps80
  common hprnutang_iau80_args,   farg80
  common hprnutang_iau96_args,   farg96

  if n_params() EQ 0 then begin
      message, 'USAGE:', /info
      message, 'HPRNUTANG, JDTT, ZETA, THETA, Z, DPSI, DEPS, '+ $
        '[ TBASE=, /JPL, /USE_EOPDATA, /NO_UT1, FIXED_EPOCH=, FIXED_BASE=, '+ $
        'POLAR_X=, POLAR_Y=, JD_UT1=, MEAN_OBLIQUITY=, TRUE_OBLIQUITY=, '+$
        'GMS_TIME=, GAS_TIME=, EQ_EQUINOX= ]', /info
      return
  endif

  if n_elements(arg80) EQ 0 then begin
      hprnutang_init_iau1980, arg80, psi80, eps80 ;; IAU 1980 Nutation theory
      hprnutang_init_iau1980_args, farg80 ;; Fund. args of 1980 theory
      hprnutang_init_iau1996_args, farg96 ;; Fund. args of 1996 theory
  endif

; if keyword_set(arg96) then farg = farg96 else farg = farg80
  farg = farg80

  ;; Default angular units
  if n_elements(angunits0) EQ 0 then $
    angunits = 'RADIAN' $
  else $
    angunits = strtrim(strupcase(strcompress(angunits0(0))),2)

  ;; Default time bases
  if n_elements(tbase0) EQ 0 then tbase = 0d $
  else                            tbase = double(tbase0)

  if n_elements(fbase0) EQ 0 then fbase = 0d $
  else                            fbase = double(fbase0)
  
  ;; "Fixed" epoch, which is the epoch of equinox that coordinates are
  ;; precessed *to*, default 2000
  if n_elements(tfixed0) EQ 0 then fepoch = 2451545.0D - fbase $
  else                             fepoch = double(fepoch0(*))

  ;; Form epoch of date in centuries from J2000.0
  t = (jdtt(*) + (tbase - 2451545.0d))/36525d

  ;; Angular conversion factors
  TWOPI = 2d*!dpi
  AS2R  = !dpi/3600d/180d         ;; 1   arcsec to radians
  MAS2R = !dpi*0.0001d/3600d/180d ;; 0.1 milliarcsec to radians

  ;; Interpolate the JPL ephemerides of nutations if requested
  if keyword_set(jpl) then begin
      ;; Markwardt-specific function
      forward_function get_xtecal

      sz = size(jpl)
      if sz(sz(0)+1) EQ 7 then efile = strtrim(jpl(0),2) $
      else efile = find_with_def('JPLEPH.405','ASTRO_DATA')

      if efile EQ '' then begin
          catch, catcherr
          if catcherr EQ 0 then efile = get_xtecal()+'clock/JPLEPH.200'
          catch, /cancel
          if efile EQ '' then $
            message, 'ERROR: could not find JPL ephemeris'
      endif

      jdlimits = [min(jdtt+tbase)-1, max(jdtt+tbase)+1]

      jplephread, efile, info, raw, jdlimits, status=st, errmsg=ee
      if st EQ 0 then message, ee
      jplephinterp, info, raw, jdtt, dpsi, deps, $
        object='NUTATIONS', tbase=tbase

      goto, PRECESS_ANGLES
  endif

  ;; Do this equation in chunks, in case of a large input time array
  dpsi = t*0 & deps = dpsi

  nt = n_elements(t)
  ns = 1000L
  if NOT keyword_set(nonut1) then for i = 0L, nt-1, ns do begin

      ;; Compute indices of input and output arrays
      imax = (i+ns-1)<(nt-1)
      ti = t(i:imax)
      if n_elements(one) NE n_elements(ti) then $
        one = ti*0 + 1

      ;; Compute the fundamental arguments: mean anom of Moon; mean anom
      ;; of Sun; long. of Moon minus long. of Moon's node; mean elongation
      ;; betw. Moon & Sun; mean long. of asc. node of Moon
      ;; ESAA Table 3.222.2
      fundargs = [[poly(ti, farg(*,0))], [poly(ti, farg(*,1))], $
                  [poly(ti, farg(*,2))], [poly(ti, farg(*,3))], $
                  [poly(ti, farg(*,4))]] MOD TWOPI

      ;; ESAA Eqn 3.222-6 (lower equation)
      arg = arg80 # transpose(temporary(fundargs))

      ;; IAU 1980 Nutation in longitude and obliquity (radians)
      ;; ESAA Eqn 3.222-6 (upper equations) and Table 3.222.1
      dpsi(i:imax) = total( (psi80(*,0)#one + psi80(*,1)#ti) * sin(arg), 1)
      deps(i:imax) = total( (eps80(*,0)#one + eps80(*,1)#ti) * cos(arg), 1)
      arg = 0
  endfor

  ;; Above quantities are in mas, convert to radians
  dpsi = dpsi * MAS2R
  deps = deps * MAS2R

  PRECESS_ANGLES:
  ;; Precession from epoch of date to "fixed" epoch
  ;; ESAA Eqn 3.211-2
  t0 = ((fbase-2451545d0) + fepoch)       / 36525d0
  td = ((tbase-fbase) + (jdtt(*)-fepoch)) / 36525d0

  ;; Arguments of ZETA, Z and THETA (part of ESAA Table 3.211.1)
  ;; Symbology note:  ESAA's T is my t0;    ESAA's t is my td
  w1 = poly(t0, [2306.2181d,  1.39656d, -0.000139d])
  w2 = poly(t0, [2004.3109d, -0.85330d, -0.000217d])
  
  ;; IAU 1976 Precession quantities (arcsec)
  ;; Remainder of ESAA Table 3.211.1
  zeta  = (w1 + (( 0.30188D0 - 0.000344D0 * t0 ) + 0.017998D0 * td ) * td )*td
  z     = (w1 + (( 1.09468D0 + 0.000066D0 * t0 ) + 0.018203D0 * td ) * td )*td
  theta = (w2 + ((-0.42665D0 - 0.000217D0 * t0 ) - 0.041833D0 * td ) * td )*td
  ;; ABOVE QUANTITIES ARE IN ARCSEC!
  w1 = 0 & w2 = 0 & td = 0 & t0 = 0  ;; Memory

  ;; Get earth orientation parameters, UT1-UTC
  ;; Convert TT to UT1
  jdtai = jdtt(*) - 32.184d/86400d
  jdutc = jdtai + tai_utc(jdtai + tbase, /invert)/86400d

  ;; Query the EOP database, or set the values to zero
  if keyword_set(useeop) then begin
      eopdata, jdutc, pmx, pmy, ut1_utc, dpsi1, deps1, tbase=tbase

      ;; Adjust the values of the nutation in longitude and obliquity
      deps = deps + deps1
      dpsi = dpsi + dpsi1

      deps1 = 0 & dpsi1 = 0 ;; Memory
  endif else begin
      pmx = 0 & pmy = 0 & ut1_utc = 0 
  endelse
  if keyword_set(no_ut1) then ut1_utc = 0

  ;; Mean obliquity of ecliptic at epoch of date (arcsec)
  ;; ESAA Eqn 3.222-1
  eps0 = poly(t, [84381.448D0, -46.8150D0, -0.00059D0, +0.001813D0]) * AS2R

  ;; True obliquity of ecliptic at epoch of date
  ;; ESAA Eqn 3.222-2
  eps = eps0 + deps

  ;; Greenwich Mean Sidereal Time
  jdut1 = jdutc + ut1_utc/86400d
  jdutc = 0 & jdtai = 0 & & ut1_utc = 0 ;; Memory
  t1 = ((tbase-2451545D) + jdut1) / 36525d

  ;; ESAA Eqn 2.24-1
  gmst1 = poly(t1, [24110.54841d, 8640184.812866d, 0.093104d, -6.2D-6])/86400d
  gmst = (gmst1 MOD 1d) + (jdut1 MOD 1d) + (tbase MOD 1d) + 3.5d
  gmst = TWOPI*( gmst MOD 1d )
  t1 = 0 & gmst1 = 0 ;; Memory

  ;; Equation of the equinoxes - includes two terms depending on the
  ;; mean longitude of the ascending node of the moon.
  ;; ESAA Sec. 3.223 and (IERS Conventions 1996)
  om = poly(t, farg(*,4)) MOD TWOPI
  eqeq = dpsi * cos(eps) + AS2R * (2.64d-3*sin(om) + 6.3d-5*sin(2d*om))
  om = 0 ;; Memory
  
  ;; Greenwich Apparent Sidereal Time
  ;; ESAA Sec. 3.223
  gast = gmst + eqeq

  ;; Units conversions
  case angunits of 
      'ARCSEC': begin
          R2AS = 1d/AS2R ;; Radian to arcsec

          dpsi = dpsi * R2AS
          deps = deps * R2AS
          eps  = eps  * R2AS
          eps0 = eps0 * R2AS
          eqeq = eqeq * R2AS
          pmx  = pmx  * R2AS
          pmy  = pmy  * R2AS
      end
      
      'RADIAN': begin   ;; Arcsec to radians
          zeta = zeta * AS2R 
          z    = z    * AS2R
          theta= theta* AS2R
      end

      ;; Also convert to degrees?

      else: begin
          message, 'ERROR: angular unit '+angunits+$
            ' was not recognized'
      end
  end

  return
end
;+
; NAME:
;   HPRSTATN
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Compute high precision earth station positions in inertial coordinates
;
; MAJOR TOPICS:
;   Geometry
;
; CALLING SEQUENCE:
;   HPRSTATN, JDTT, R_ITRF, R_ECI, V_ECI, $
;             [ /JPL, /USE_EOP, /NO_UT1, TBASE= ]
;
; DESCRIPTION:
;
;  The procedure HPRSTATN computes the coordinates and velocities of
;  an earth station in J2000 equatorial earth-centered inertial
;  coordinates (ECI).  This may be useful in any application where an
;  earthbound observatory is used to collect data on a non-terrestrial
;  phenomenon.
;
;  The user must have the following routines involved: HPRNUTANG;
;  Markwardt Quaternion Library; JPLEPHREAD and JPLEPHINTERP (if JPL
;  keyword is used); EOPDATA (if USE_EOP keyword is set); and TAI_UTC.
;  Also, the appropriate data files for TAI-UTC and Earth Orientation
;  Parameters must be installed.
;
;  The user must specify the position of the earth station in
;  earth-centered, earth-fixed, cartesian coordinates of the ITRF.
;  The Z-axis points to terrestrial north, the X-axis lies in the
;  terrestrial equator pointing towards the Greenwich meridian, and
;  the Y-axis forms the right handed coordinate system.  Any
;  positional units may be specified.
;
;  For the highest precision, the preferred method is to know the
;  coordinates from a direct IRTF reduction, i.e., via VLBI.  If you
;  have geodetic longitude/latitude, a procedure is given below which
;  can covert geodetic coordinates referred to WGS84 to ITRF cartesian
;  coordinates.
;
;  The values returned are the earth-centered inertial J2000
;  coordinates and velocities of the station.  All the effects of
;  earth rotation, precession, nutation, and polar motion can be
;  included.  The user has a choice of the kinds of transformations
;  that are included (see JPL, USE_EOP and NO_UT1 keywords).
;
;  The returned positional units are the same as the input units.  The
;  returned velocity units are (units of input) PER SECOND.
;
;  It is possible specify more than one time, or more than one station
;  position, or both.  If both more than one time and position are
;  specified, then there must be an equal quantity of both.
;
;
; CARTESIAN COORDINATES FROM GEODETIC COORDINATES
;
;  For a station whose geodetic latitude LAT, longitude LON (where
;  positive is east) and elevation H specified relative to the
;  ellipsoid, the cartesian coordinates are:
;
;         R_ITRF = [ (A*C + H)*COS(LAT)*COS(LON), $
;                    (A*C + H)*COS(LAT)*SIN(LON), $
;                    (A*S + H)*SIN(LAT) ]
;
;  where for the WGS84 reference ellipsoid, the equatorial radius is
;  set to A = 6378.137 km, and the flattening factor F =
;  1/298.257223563, and
;
;      C = 1.0/SQRT(COS(LAT)^2 + (1 - F)^2*SIN(LAT)^2)
;      S = (1 - F)^2 * C
;
;  Reference: Explanatory Supplement to the Astronomical Almanac,
;  eqns. 3.351-1 and 3.352-2.
;
;
; INPUTS:
;
;   JDTT - a scalar or N-vector, the TT epoch time(s) for which
;          station coordinates are to be computed.
;
;          For reference, JDTT = JDTAI + 32.184/86400d, where JDTAI is
;          the international atomic time measured in days.  The value
;          of the keyword TBASE is added to JDTT to arrive at the
;          actual Julian date.
;
;   R_ITRF - cartesian coordinates of earth station.  Either a
;            3-vector, or a 3xN array.  Units can be any positional
;            units.
;
;
; OUTPUTS:
;
;   R_ECI - upon output, the coordinates of the station at the given
;           time(s), referred to the earth-centered J2000 coordinate
;           system.  Either a 3-vector or 3xN array depending on the
;           input.  Units are the same as for R_ITRF.
;
;   V_ECI - upon output, the velocities of the station at the given
;           time(s), referred to the earth-centered J2000 coordinate
;           system.  Either a 3-vector or 3xN array depending on the
;           input.  Units are (units of R_ITRF) PER SECOND.
;
;
; KEYWORD PARAMETERS:
;
;   TBASE - a fixed epoch time (Julian days) to be added to each value
;           of JDTT.  Since subtraction of large numbers occurs with
;           TBASE first, the greatest precision is achieved when TBASE
;           is expressed as a nearby julian epoch, JDTT is expressed
;           as a small offset from the fixed epoch.  
;           Default: 0
;
;   JPL - if set, then the JPL ephemeris is used to compute nutation
;         angles.  Otherwise the series representation of HPRNUTANG is
;         used.
;
;   USE_EOP - if set, then use earth orientation parameters, returned
;             by EOPDATA, to further refine the station coordinates.
;             Otherwise, only precession and nutation are used.
;
;   NO_UT1 - if set, then do not use the UT1-UTC conversion.
;   NO_PRECESSION - disable precession calculation.
;   NO_NUTATION - disable nutation calculation.
;   NO_POLAR_MOTION - disable polar motion calculation.
;
;
; EXAMPLE:
;
;   ;; ITRF coordinates of Deep Space Network Antenna 63 (METERS)
;   R_DSN63 = [+4849092.647d, -0360180.569d, +4115109.113d]
;
;   ;; Time: 2000/01/01 01:30 TT
;   JDTT = jday(2000d,1,1) + 1.5/24
;
;   ;; Compute position of antenna in J2000 coordinate system using
;   ;; full Earth Orientation Parameters.
;   HPRSTATN, JDTT, R_DSN63, R_ECI, V_ECI, /USE_EOP
;
;
; SEE ALSO:
;
;   HPRNUTANG, TAI_UTC (Markwardt Library)
;   EOPDATA, JPLEPHREAD, JPLEPHINTERP
;
;
; REFERENCES:
;
;   McCarthy, D. D. (ed.) 1996: IERS Conventions, IERS T.N. 21.
;     http://maia.usno.navy.mil/conventions.html
;
;   Seidelmann, P.K. 1992, *Explanatory Supplement to the Astronomical
;     Almanac*, ISBN 0-935702-68-7
;
;
; MODIFICATION HISTORY:
;   Written, 6 May 2002, CM
;   Documented, 12 May 2002, CM
;   Corrected discussion of geodetic coordinates, 26 May 2002, CM
;   Add NO_POLAR_MOTION keyword; only compute V_ECI if the variable
;    is passed, 07 Mar 2007, CM
;   Save some memory by deleting variables that are no longer used,
;    19 Dec 2008, CM
;   Some small documentation improvements, 16 Jan 2010, CM
;   Correct error in calculation of conversion from geodetic lat/lon
;     to cartesian, and add references, 2010-05-12, CM
;
;  $Id: hprstatn.pro,v 1.8 2010/05/12 22:17:32 craigm Exp $
;
;-
; Copyright (C) 2002, 2007, 2008, 2010, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   INPUTFORM
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Generates expression string from an IDL value
;
; CALLING SEQUENCE:
;   STRING = INPUTFORM(VALUE, ERRMSG=ERRMSG, STATUS=STATUS, ...)
;
; DESCRIPTION: 
;
;   The INPUTFORM function converts an IDL data value into its string
;   representation, suitable for execution at the IDL command line or
;   with EXECUTE().  This is similar to the "InForm" output
;   representation of Mathematica, which formats output so that it can
;   be entered again on the command line.  INPUTFORM() is a
;   specialized form of STRING().
;
;   For example, the value DBLARR(2,2) has the default representation
;
;      '[[0D,0],[0D,0]]'
;
;   The formal goal of INPUTFORM is for the resulting textual
;   expression to be an exact representation of the original data.
;   Several other output options can be selected by using the /ZERO or
;   /ARRAY_NOTATION keywords.
;
;   Therefore, given the original value VARIABLE, then after executing
;
;      R = EXECUTE( 'variable1 = '+INPUTFORM(variable) )
;
;   The value, type, and dimension of VARIABLE1 and VARIABLE will be
;   the same.  
;
;   Such behavior might useful in several circumstances:
;
;      * for printing values meant to be "pasted" back into the
;        command line by the user;
;      * for constructing command arguments to be EXECUTE()'d;
;      * for saving values in ASCII format for later execution.
;
; OUTPUT OPTIONS:
;
;   The output of INPUTFORM can be controlled in the following ways.
;   See the EXAMPLES section for examples of each kind of behavior.
;
;      * By default, the output will replicate the exact values of the
;        input;
;      * If the /ZERO keyword parameter is set, then the output will
;        match the type and structure of the input, but all values
;        will be zero or blank, including IDL strings and structures.
;        This is useful if one wants to make a "blank template" from
;        an existing IDL data structure.
;      * If the /ARRAY_NOTATION keyword parameter is set, then any
;        input arrays are converted to INTARR(), DBLARR(), STRARR().
;        Scalars appear as in the input.  Obviously the contents of
;        arrays will be zero/blank in this case.  The combination of
;        /ZERO and /ARRAY_NOTATION produces a nice short-hand
;        blank template.
;
; LIMITATIONS:
;   
;   It should be noted that the IDL parser is not perfect.
;   While IDL has many data types, not all expressions are
;   representable as a textual string.  Pointers and objects can be
;   represented.  Examples of the parser limitation include,
;
;      * array expressions can have no more than 90 elements;
;      * bracketed array notation cannot be nested too deeply;
;      * anonymous structure arrays have no textual representation;
;
;   Given these limitations, the user of this routine must be prepared
;   for failure and have contingency plans.  Error messages and status
;   indicators are provided to facilitate this.  INPUTFORM() does not
;   call MESSAGE, so it should never intentionally crash.
;
;   Also, consider that the textual representation can never really be
;   suitable for very large arrays.  The internal algorithm is thus
;   not optimized for speed as heavily numeric routines might be, and
;   instead tries to make the output slightly more readable.
;
; INPUTS:
;
;   VALUE - the IDL value to be converted.  Any value which has a
;           legal textual representation is permitted.
;
; KEYWORDS:
;
;   ARRAY_NOTATION - if set, then any arrays in the input will be
;            replaced by their xxxARR() equivalent.
;
;   STATUS - upon return, a status indicator.  A value of zero
;            indicates failure; one indicates success.
;
;   ERRMSG - upon return, a string message indicating the reason for a
;            failure, if any.  The empty string ('') indicates
;            success.
;
;   MAX_DIMENSIONS - maximum number of array dimensions permitted in
;                    VALUE.  The conversion fails if the maximum is
;                    exceeded.
;                    Default: any number of dimensions is permitted.
;
;                    NOTE: IDL does not permit deep nesting, for
;                    dimensions greater than three.
;
;   MAX_ELEMENTS - maximum number of elements permitted in VALUE.  The
;                  conversion fails if the maximum is exceeded.
;                  Default: any number of elements is permitted.
;
;                  NOTE: the conversion may still fail if any array
;                  dimension exceeds 90.
;
;   MAX_LEN - approximate maximum length of returned string.  If large
;             string expressions exceed this size as they are being
;             composed internally, they will be terminated by a '...'
;             ellipsis and returned.  This value is to be used as a
;             guideline by INPUTFORM(); the precise limit may not be
;             adhered to.
;             Default: 16384L
;
;   MAX_TAGS - maximum number of structure tags permitted in VALUE.
;              The conversion fails if the maximum is exceeded.
;              Default: any number of tags is permitted.
;
;   N_FLOAT - for floating point numerical values, N_FLOAT gives the
;             number of decimal digits to print.  By definition,
;             setting this keyword will involve the loss of some
;             precision compared to the original value.
;             Default: full precision is printed.
;
;   ZERO - if set, then the output command will have zero values for
;          all fields, regardless of the contents of the input data.
;
;            
; RETURNS:
;   The resulting converted string, if successful.  Upon failure,
;   STATUS is set to zero and the empty string ('') is returned.
;
; EXAMPLE:
;   
;   Convert a double array to text using the default output option,
;     IDL> x = [[1,2],[3,4]]
;     IDL> print, inputform(x)
;     --->   [[1,2],[3,4]]
;
;   The same input, but using the /ZERO and /ARRAY_NOTATION options,
;     IDL> print, inputform(x, /zero)
;     --->   [[0,0],[0,0]]
;     IDL> print, inputform(x, /array_notation)
;     --->   INTARR(2L,2L)
;
;   Convert a structure,
;     IDL> y = create_struct('s1',5,'s2','strvalue','s3',[1,2,3])
;     IDL> print, inputform(y)
;     --->   [{S1:5,S2:'strvalue',S3:[1,2,3]}]
;
;   Also with /ZERO and /ARRAY_NOTATION options,
;     IDL> print, inputform(y, /zero)
;     --->   {S1:0,S2:'',S3:[0,0,0]}
;     IDL> print, inputform(y, /array_notation)
;     --->   {S1:5,S2:'strvalue',S3:INTARR(3L)}
;     (Note that in the final case with /ARRAY_NOTATION alone, S3 is
;      replaced by INTARR(), but that the scalars are left unchanged.)
;     IDL> print, inputform(y, /zero, /array_notation)
;     --->   {S1:0,S2:'',S3:INTARR(3L)}
;     (With /ZERO and /ARRAY_NOTATION combined, then all fields are
;      zero or blank).
;
; SEE ALSO:
;
;   STRING, PRINT, HELP, HELPFORM
;
; MODIFICATION HISTORY:
;   Written, CM, 10 Apr 2000
;   Added HELPFORM to SEE ALSO, CM, 04 Jul 2000
;   Corrected case of scalar float value, CM, 13 Jul 2000
;   Put a space after float types like 1E or 1D to ease parsing, CM,
;     18 Jul 2000
;   Add ability to print INPUTFORM of pointers, CM, 09 Dec 2002
;   Add ability to print INPUTFORM of object pointers, CM, 01 Oct 2003
;   Bug fix: actually obey MAX_ELEMENTS (was being ignored), CM, 22
;     Oct 2006
;   Change to square-bracket array syntax, CM, 27 Feb 2007
;   Add the ZERO and ARRAY_NOTATION keywords; handle NAN and INFINITY
;     values properly, CM, 02 Jun 2009
;   Add N_FLOAT keyword, CM, 13 Nov 2010
;   
;
;  $Id: inputform.pro,v 1.8 2010/11/13 09:27:36 cmarkwar Exp $
;
;-
; Copyright (C) 2000,2001,2002,2003,2006,2007,2009,2010 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Forward declarations of functions, for goodness's sake
forward_function inputform_int, inputform_float, inputform_string, $
  inputform_struct, inputform_basic, inputform

;; Convert an integer style value to a string
function inputform_int, x, format, zero=zero
  COMPILE_OPT strictarr
  n = n_elements(x)
  if keyword_set(zero) then x[*] = 0
  ;; Construct format like (N(format,:,","))
  fmt = '('+strtrim(n,2)+'('+format+',:,","))'
  return, string(x, format=fmt)
end

;; Convert a floating style value to a string.  Note the conversion
;; happens twice, once as a E and once as a G.  The shortest correct
;; version of the two is used.
function inputform_float, x, format, dconvert=dcon, zero=zero, $
                          nfloat=nfloat
  COMPILE_OPT strictarr
  n = n_elements(x)
  sz = size(x) & tp = sz[sz[0]+1]

  gfmt = 'G0'
  if n_elements(nfloat) GT 0 then gfmt = gfmt+'.'+strtrim(nfloat,2)
  gfmt = '('+gfmt+')'

  if keyword_set(zero) then begin
      x[*] = 0
      str = string(x, format=gfmt)
  endif else begin

      str = string(x[*], format=format)

      ;; Sorry, there appears to be no other way to make nice looking
      ;; floating point numbers.
      str1 = string(x[*], format=gfmt)
      if n_elements(nfloat) EQ 0 then begin
          if tp EQ 4 then x1 = float(str1)
          if tp EQ 5 then x1 = double(str1)
          wh = where(x-x1 EQ 0, ct)
          if ct GT 0 then str[wh] = str1[wh]
          str1 = 0
      endif else begin
          str = temporary(str1)
      endelse
  endelse
  str = strtrim(str,2)

  p = strpos(str[0], 'E')  ;; Make sure at least one element is float-type
  ;; Note, the space is needed in case the string is placed inside
  ;; another expression down the line.
  if p LT 0 then begin
      if keyword_set(dcon) then str[0] = str[0] + 'D' $
      else str[0] = str[0] + 'E'
  endif
  if keyword_set(dcon) then begin
      ;; Convert from floating to double
      p = strpos(str, 'E')
      wh = where(p GE 0, ct)
      for i = 0L, ct-1 do begin
          str1 = str[wh[i]]
          strput, str1, 'D', p[wh[i]]
          str[wh[i]] = str1
      endfor
  endif

  if NOT keyword_set(zero) then begin
      ;; Handle NAN
      wh = where(x NE x, ct)
      if ct GT 0 then begin
          str[wh] = (keyword_set(dcon)) ? ('!VALUES.D_NAN') : ('!VALUES.F_NAN')
      endif
      
      ;; Handle infinities
      ;; ... plus infinity ...
      wh = where(x EQ !values.d_infinity, ct)
      if ct GT 0 then begin
          str[wh] = (keyword_set(dcon)) ? ('!VALUES.D_INFINITY') : ('!VALUES.F_INFINITY')
      endif
      ;; ... minus infinity ...
      wh = where(x EQ -!values.d_infinity, ct)
      if ct GT 0 then begin
          str[wh] = (keyword_set(dcon)) ? ('-!VALUES.D_INFINITY') : ('-!VALUES.F_INFINITY')
      endif
  endif

  ;; Construct format like (N(A,:,","))
  fmt = '('+strtrim(n,2)+'(A,:,","))'
  return, string(str, format=fmt)
end

;; Convert a string to a string.  This means protecting against stray
;; quotation marks.
function inputform_string, x, zero=zero
  COMPILE_OPT strictarr
  n = n_elements(x)

  if keyword_set(zero) then begin
      x1 = strarr(n)
  endif else begin
      x1 = x
      ;; Strings must be protected against having quotation marks within
      ;; themselves
      wh = where(strpos(x1, "'") GE 0, ct)
      if ct GT 0 then begin
          for i = 0L, ct-1 do begin
              x2 = x1[wh[i]]
              ;; Find each quotation mark and replace it
              p = strpos(x2, "'")
              while p GE 0 do begin
                  l = strlen(x2)
                  if p GE 0 then x2 = strmid(x2, 0, p)+"'"+strmid(x2, p, l-p)
                  p = strpos(x2, "'", p+2)
              endwhile
              x1[wh[i]] = x2
          endfor
      endif
  endelse

  ;; Now protected, the strings can be joined
  fmt = '('+strtrim(n,2)+'("''",A,"''",:,","))'
  return, string(x1, format=fmt)
end

;; Convert a structure type.  Recursive calls to inputform() are
;; performed to convert the internal tag values.
function inputform_struct, data, status=status, errmsg=errmsg, zero=zero, $
                           array_notation=arrnot, nocatch=nocatch, $
                           nfloat=nfl
  COMPILE_OPT strictarr
  n = n_elements(data)
  s0 = ''
  tn = tag_names(data)
  sn = tag_names(data, /structure_name)
  for i = 0L, n-1 do begin
      s = '{'
      ;; Open braces and add structure name if possible
      if sn NE '' then s = s + sn + ','
      comma = ''
      for j = 0L, n_elements(tn)-1 do begin
          ;; Add each tag
          status = 0
          s = s + comma + tn[j] + ':' + $
            inputform(data[i].(j), status=status, errmsg=errmsg, max_dim=2, $
                      zero=zero, array_notation=arrnot, $
                      n_float_digits=nfloat, $
                      nocatch=nocatch)
          if status NE 1 then return, ''
          comma = ','
      endfor
      s = s + '}'
      if i NE n-1 then s = s + ','
      s0 = s0 + s
  endfor
  status = 1
  return, s0
end

;; Convert pointer
function inputform_ptr, x, tp, zero=zero
  COMPILE_OPT strictarr
  nel = n_elements(x)

  if tp EQ 10 then fun = 'PTR' else fun = 'OBJ'
  if keyword_set(zero) then begin
      if nel EQ 1 then return, fun+'_NEW()'
      return, string(fun, nel, format='(A0,"_ARR(",I0,")")')
  endif

  ;; Convert to string representation, then fish out the integers
  strep = string(x, /print)
  stb = byte(strep)
  st0 = stb*0b + 32b
  ;; Fish out the integers...
  wh = where(stb GE (byte('0'))[0] AND stb LE (byte('9'))[0], ct)
  if ct GT 0 then st0[wh] = stb[wh]
  
  ;; .. but also replace Nulls with 0 and '>' with commas
  wh = where(stb EQ (byte('>'))[0], ct)
  if ct GT 0 then st0[wh] = (byte(','))[0]
  wh = where(stb EQ (byte('N'))[0], ct)
  if ct GT 0 then st0[wh] = (byte('0'))[0]

  sti = strcompress(string(st0),/remove_all)
  dummy = execute('ind = [0L,'+sti+'0L]')
  ind = ind[1:nel]

  ;; Convert to a list of pointers using PTR_VALID and /CAST
  format = '('+strtrim(nel,2)+'("'+fun+'_valid(",I0,",/cast)",:,","))'
  stf = string(ind, format=format)

  return, stf
end

;; Convert basic types
function inputform_basic, x, status=status, errmsg=errmsg, si=si, zero=z, $
                          array_notation=arrnot, nocatch=nocatch, $
                          nfloat=nfl
  COMPILE_OPT strictarr

  s = ''
  si = ''
  status = 1
  sz = size(x)
  tp = sz[sz[0]+1]
  case (tp) of 
      1:  s = inputform_int(x, '(I0,"B")', zero=z)      ;; BYTE
      2:  s = inputform_int(x, '(I0)', zero=z)          ;; INTEGER
      3:  s = inputform_int(x, '(I0,"L")', zero=z)      ;; LONG
      4:  s = inputform_float(x, '(E)', zero=z,nfl=nfl) ;; FLOAT
      5:  s = inputform_float(x, '(E)', /dconv, zero=z,nfl=nfl) ;; DOUBLE
      7:  s = inputform_string(x, zero=z)               ;; STRING
      10: s = inputform_ptr(x,10, zero=z)               ;; POINTER
      11: s = inputform_ptr(x,11, zero=z)               ;; OBJPTR
      12: s = inputform_int(x, '(I0,"U")', zero=z)      ;; UNSIGNED INTEGER
      13: s = inputform_int(x, '(I0,"UL")', zero=z)     ;; UNSIGNED LONG
      14: s = inputform_int(x, '(I0,"LL")', zero=z)     ;; LONG64
      15: s = inputform_int(x, '(I0,"ULL")', zero=z)    ;; UNSIGNED LONG64  
      
      6: begin ;; COMPLEX
          s  = inputform_float(float(x), '(E)', zero=z, nfl=nfl)
          si = inputform_float(imaginary(x), '(E)', zero=z, nfl=nfl)
      end
      9: begin ;; DCOMPLEX
          s  = inputform_float(double(x), '(E)', /dconv, zero=z, nfl=nfl)
          si = inputform_float(imaginary(x), '(E)', /dconv, zero=z, nfl=nfl)
      end
      
      8: begin ;; STRUCTURE
          s = inputform_struct(x, status=status, errmsg=errmsg, zero=z, $
                               array_notation=arrnot, nocatch=nocatch, nfl=nfl)
          if status EQ 0 then return, ''
      end

      else: return, ''
  end

  return, s
end


function inputform_array1, type, dims
  COMPILE_OPT strictarr
  return, type+'('+inputform_int(dims, '(I0,"L")')+')'
end

function inputform_array, x, status=status, errmsg=errmsg, si=si
  COMPILE_OPT strictarr

  s = ''
  si = ''
  sz = size(x)
  tp = sz[sz[0]+1]
  ndim = sz[0]
  dims = sz[1:ndim]

  status = 0

  case (tp) of 
      1:  s = inputform_array1('BYTARR',dims)       ;; BYTE             
      2:  s = inputform_array1('INTARR',dims)       ;; INTEGER          
      3:  s = inputform_array1('LONARR',dims)       ;; LONG             
      4:  s = inputform_array1('FLTARR',dims)       ;; FLOAT            
      5:  s = inputform_array1('DBLARR',dims)       ;; DOUBLE           
      6:  s = inputform_array1('COMPLEXARR',dims)   ;; COMPLEX
      7:  s = inputform_array1('STRARR',dims)       ;; STRING           
      9:  s = inputform_array1('DCOMPLEXARR',dims)  ;; DCOMPLEX
      10: s = inputform_array1('PTRARR',dims)       ;; POINTER          
      11: s = inputform_array1('OBJARR',dims)       ;; OBJPTR           
      12: s = inputform_array1('UINTARR',dims)      ;; UNSIGNED INTEGER 
      13: s = inputform_array1('ULONARR',dims)      ;; UNSIGNED LONG    
      14: s = inputform_array1('LON64ARR',dims)     ;; LONG64           
      15: s = inputform_array1('ULON64ARR',dims)    ;; UNSIGNED LONG64  
      
      else: begin
          errmsg = 'Cannot make ARRAY notation for type '+strtrim(tp,2)
          return, ''
      end
  end

  status = 1
  return, s
end


function inputform_brackets, s, l, r, si=si, status=status, errmsg=errmsg
  COMPILE_OPT strictarr

  if status EQ 0 then return, s

  for i = 0, l-1 do begin
      s  = '[' + s
      if n_elements(si) GT 0 then if si NE '' then si = '[' + si
  endfor
  for i = 0, r-1 do begin
      s  = s + ']'
      if n_elements(si) GT 0 then if si NE '' then si = si + ']'
  endfor

  return, s
end



;; Main routine
function inputform, data, errmsg=errmsg, status=status, max_elements=nmax, $
                    max_dimensions=nmaxd, max_tags=nmaxt, max_len=nmaxl, $
                    array_notation=arrnot, zero=z, $
                    n_float_digits=nfl, $
                    nocatch=nocatch

  COMPILE_OPT strictarr
  status = 0
  expr = ''
  errmsg = ''

  ;; General error catching, in case we didn't get everything
  catcherr = 0
  if NOT keyword_set(nocatch) then catch, catcherr
  if catcherr NE 0 then begin
      catch, /cancel
      status = 0
      expr = ''
      if errmsg EQ '' then errmsg = 'An unknown conversion error occurred'
      return, expr
  endif

  sz = size(data)
  typenames = ['UNDEFINED', 'BYTE', 'INTEGER', 'LONG', 'FLOAT', 'DOUBLE', $
               'COMPLEX', 'STRING', 'STRUCTURE', 'DCOMPLEX', 'POINTER', $
               'OBJECT', 'UNSIGNED INTEGER', 'UNSIGNED LONG', $
               'LONG64', 'UNSIGNED LONG64', 'UNKNOWN']

  ;; Certain types have *no* representation
  ndims = sz[0]
  tp = sz[ndims+1]
  if (tp EQ 0) OR (tp GT 15) then begin
      errmsg = 'Type '+typenames[tp<16]+' has no input representation'
      return, expr
  endif

  ;; Don't convert arrays that are too large
  ndata = n_elements(data)
  if n_elements(nmax) EQ 0 then nmax = ndata
  if ndata GT nmax[0] then begin
      errmsg = 'DATA array has too many elements'
      return, expr
  endif

  ;; Arrays cannot be too big, or have anonymous structures
  MAXLEN = nmax
  if ndims GT 0 then begin
      if max(sz[1:ndims]) GT MAXLEN then begin
          errmsg = string(MAXLEN, $
            format='("Array type is too large (>",I0," elements per dim)")')
          return, expr
      endif
      ;; Structure cannot be anonymous
      if ndata GT 1 AND tp EQ 8 then begin
          if tag_names(data[0], /structure) EQ '' then begin
              errmsg = 'Arrays of anonymous structures are not permitted'
              return, expr
          endif
      endif
  endif

  odims = 1L     ;; "OUTER" dimensions 
  fdims = sz[1]  ;; "INNER" dimensions
  if ndims EQ 0 then fdims = 1L
  if ndims GE 2 then for i = 2, ndims do odims = odims * sz[i]

  if ndims GT 0 then begin
      dims = sz[1:ndims]
  endif else begin
      dims = [0L]
  endelse

  ;; Look for the maximum number of dimensions or structure tags
  if n_elements(nmaxd) GT 0 then if ndims GT nmaxd[0] then begin
      errmsg = 'Array has too many dimensions'
      return, expr
  endif
  if tp EQ 8 AND n_elements(nmaxt) GT 0 then $
    if n_elements(tag_names(data[0])) GT nmaxt[0] then begin
      errmsg = 'Structure has too many tags'
      return, expr
  endif

  ;; Create a nicer array to work with
  ss  = '' & ssi = ''
  x = reform([data], fdims, odims)

  case 1 of 
      (NDIMS EQ 0): begin    ;;; =========== SCALAR
          ss = inputform_basic(data, si=ssi, status=status, errmsg=errmsg, zero=z, nfl=nfl)
      END

      ((NDIMS EQ 1) AND (TP EQ 8) AND (NDATA EQ 1)): begin ;; ====== SCALAR STRUCT
          ss = inputform_basic(data, si=ssi, status=status, errmsg=errmsg, zero=z, $
                               nocatch=nocatch, array_notation=arrnot, nfl=nfl)
      END

      (keyword_set(arrnot) AND (TP NE 8)): begin
          ss = inputform_array(data, status=status, errmsg=errmsg)
      end
          
      (NDIMS EQ 1): begin    ;;; =========== 1-D ARRAY
          ss = inputform_basic(data, si=ssi, status=status, errmsg=errmsg, zero=z, nfl=nfl)
          ss = inputform_brackets(ss, 1, 1, si=si, status=status, errmsg=errmsg)
      end
          
      else: begin    ;; ========== Higher dimensional arrays
          xdims = dims[1:*]
          for i = 1, ndims-2 do xdims[i] = xdims[i]*xdims[i-1]
  
          comma = ''
          
          for i = 0L, odims-1 do begin
              
              xx = x[*,i]
              
              ;; Opening and closing brackets depends on whether we
              ;; are at the end of a multiple of the array dimensions.
              wh = where((i MOD xdims) EQ 0,     nleft)  & nleft  = nleft  + 1
              wh = where(((i+1) MOD xdims) EQ 0, nright) & nright = nright + 1

              ;; Representation with brackets
              s = inputform_brackets(inputform_basic(xx, si=si, zero=z, nfl=nfl, $
                                                     errmsg=errmsg, status=status), $
                                     nleft, nright, si=si, $
                                     errmsg=errmsg, status=status)

              ;; Accumulate with previous values
              ss  = ss  + comma + s
              ssi = ssi + comma + si 

              if status EQ 0 then break

              comma = ','
              if n_elements(nmaxl) GT 0 then $
                if strlen(ss)+strlen(ssi) GT nmaxl[0] then begin
                  ss = ss + '...'
                  ssi = ssi + '...'
                  break
              endif

          endfor
      end
  endcase

  ;; If we had an error condition above, do not continue
  if status EQ 0 then return, expr

  ;; Merge real and imaginary parts together
  if NOT keyword_set(arrnot) then begin
      if tp EQ 6 then ss =  'COMPLEX('+ss+','+ssi+')'
      if tp EQ 9 then ss = 'DCOMPLEX('+ss+','+ssi+')'
  endif
  s = ''
  ;; Final dimensions can be lost if they are not reformed
  if ndims GT 1 then begin
      for j = ndims-1, 0, -1 do begin
          if dims[j] NE 1 then goto, DONE_DCHECK
      endfor
      DONE_DCHECK:
      if j NE ndims-1 then $
        ss = 'REFORM('+ss+','+inputform(dims)+')'
  endif

  ;; Return
  expr = ss
  status = 1
  return, expr
end
;+
; NAME:
;   JBEPOCH
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Compute Julian Day to/from Julian or Besselian Epoch
;
; CALLING SEQUENCE:
;   EPOCH = JBEPOCH(/B, JDAY)   ;; Julian Day to Besselian Epoch
;   EPOCH = JBEPOCH(/J, JDAY)   ;; Julian Day to Julian Epoch
;
;   JDAY  = JBEPOCH(/B, EPOCH, /TO_DAY)  ;; Besselian Epoch to Julian Day
;   JDAY  = JBEPOCH(/J, EPOCH, /TO_DAY)  ;; Julian Epoch to Julian Day
;
; DESCRIPTION: 
;
;   The function JBEPOCH computes the Julian or Besselian Epoch year
;   number from a given Julian day number.  Epochs of this form are
;   often given in the astronomical literature as B1950.0 or J2000.0,
;   but they can be different.
;
;   Besselian year numbers are measured in tropical years of about
;   365.2422 days.  Julian year numbers are measured in years whose
;   lengths are exactly 365.25 days of 86400 second lengths.  The "/J"
;   or "/B" keywords identify which year numbering system is being
;   used.
;
;   JBEPOCH also computes the inverse transformation, from Julian or
;   Besselian epoch to Julian Day, by specifying the /TO_DAY keyword.
;
;   The computational logic is inspired by STARLINK (P.T. Wallace).
;
;
; INPUTS:
;
;   EPOCH or JDAY - If TO_DAY is set, Besselian or Julian year number.
;                   If TO_DAY is not set, the Julian day number.
;
; KEYWORDS:
;
;   B - if set, then year numbers (input/output) are expressed in
;       Besselian years.
;
;   J - if set, then year numbers (input/output) are expressed in
;       Julian years.
;
;   TO_DAY - if set, then convert EJ (assumed to be year number) into
;            Julian day number.
;
;   MJD - if set, then Julian days are expressed as "modified" Julian
;         Days, or Julian days minus 2400000.5d.
;
;
; RETURNS:
;
;   If TO_DAY is set, then returns Julian Days.
;
;   If TO_DAY is not set, then returns year number.
;   
;
; REFERENCES:
;
;   Lieske, J. H. 1979, Astron & Astrophysics, 73, 282
;
;   Wallace, P. T. 1999, SLALIB Software Library (STARLINK)
;     http://star-www.st-and.ac.uk/starlink/
;     (Routines sla_EPB2D, sla_EPJ2D, sla_EPB and sla_EPJ)
;
; SEE ALSO:
;
;   JULDAY, CALDAT
;
; MODIFICATION HISTORY:
;   Written, CM, 04 Mar 2002
;   Documented, CM, 22 Mar 2002
;
;  $Id: jbepoch.pro,v 1.3 2002/03/22 22:02:02 craigm Exp $
;
;-
; Copyright (C) 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   JPLEPHINTERP
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Interpolate position and motion of planetary bodies (JPL Ephemeris)
;
; MAJOR TOPICS:
;   Planetary Orbits, Interpolation
;
; CALLING SEQUENCE:
;   JPLEPHINTERP, INFO, RAWDATA, T, X, Y, Z, [VX, VY, VZ, /EARTH, /SUN,
;         OBJECTNAME=, CENTER=, TBASE=, POSUNITS=, VELUNITS= ]
;
; DESCRIPTION:
;
;   JPLEPHINTERP interpolates the JPL DE200 or DE405 planetary
;   ephemeris to find the positions and motions of planetary bodies.
;
;   This routine is the second stage of a two-stage process to
;   interpolate the JPL ephemeris.  In this first stage, the file is
;   opened using JPLEPHREAD, and the relevant portions of the table
;   are read and stored into the two variables INFO and RAWDATA.  In
;   the second stage, the user actually interpolates the ephemeris for
;   the desired bodies and to the desired ephemeris time using
;   JPLEPHINTERP.
;
;   The only independent variable which must be specified is T, the
;   ephemeris time.  For low to moderate accuracy applications, T is
;   simply the conventional calendar date, expressed in Julian days.
;   See below for high precision applications.
;
;   Upon output, the position components of the desired body are
;   returned in parameters X, Y and Z, and if requested velocity
;   components are returned in parameters VX, VY and VZ.  Coordinates
;   are referred to the ephemeris's coordinate system: FK5 for
;   JPL-DE200 and ICRS for JPL-DE405.  By default, the origin of
;   coordinates is the solar system barycenter (SSB), unless another
;   origin is selected using the CENTER keyword.
;
;   Users must set the VELOCITY keyword to generate body velocities.
;   By default they are not generated.
;
;   Users can select the desired body by using either the EARTH or SUN
;   keywords, or the OBJECTNAME keyword.
;
;   By default, positions are returned in units of KM and velocities
;   in units of KM/DAY.  However, the output units are selectable by
;   setting the POSUNITS and VELUNITS keywords.
;
; High Precision Applications
;
;   If the required precision is finer than a few hundred meters, the
;   user must be aware that the formal definition of the ephemeris
;   time is the coordinate time of a clock placed at the solar system
;   barycenter (SSB).  If the user's time is measured by a clock
;   positioned elsewhere, then various corrections must be applied.
;   Usually, the most significant correction is that from the
;   geocenter to the SSB (see Fairhead & Bretagnon 1990; Fukushima
;   1995).  Not applying this correction creates an error with
;   amplitude ~170 nano-light-seconds ( = 50 m) on the earth's
;   position.  (see TDB2TDT)
;
;   For high precision, the user should also specify the TBASE
;   keyword.  TBASE should be considered a fixed epoch with respect to
;   which T is measured; T should be small compared to TBASE.
;   Internally, subtraction of large numbers occurs with TBASE first,
;   so truncation error is minimized by specifying TBASE.
;
; Nutations and Librations
;
;   This routine also provides information about earth nutations and
;   lunar librations, which are stored in the JPL ephemeris tables.
;   The POSUNITS and VELUNITS keywords do not affect these
;   computations.
;
;   Lunar librations in the form of three Euler angles are returned in
;   X, Y, Z, in units of radians, and their time derivatives are
;   returned in VX, VY, and VZ in units of radians per day.
;
;   The earth nutation angles psi (nutation in longitude) and epsilon
;   (nutation in obliquity) are returned in X and Y, in units of
;   radians.  Their time derivatives are returned in VX and VY
;   respectively.  The quantities returned in Z and VZ are undefined.
;
; Verification
;
;   The precision routine has been verified using JPLEPHTEST, which is
;   similar to the original JPL program EPHTEST.  For years 1950 to
;   2050, JPLEPHINTERP reproduces the original JPL ephemeris to within
;   1 centimeter.
;
; Custom Ephemerides
;
;   It is possible to make custom ephemerides using JPLEPHMAKE, or to
;   augmented an existing ephemeris with additional data.  In the
;   former case JPLEPHINTERP should automatically choose the correct
;   object from the table and interpolate it appropriately.
;
;   For augmented ephemerides, the object can be specified by name,
;   which works as expected, or by number, which has a special
;   behavior.  For augmented files only, the new objects begin at
;   number 100.
;
;
; PARAMETERS: 
;
;   INFO - structure returned by JPLEPHREAD.  Users should not modify
;          this structure.
;
;   RAWDATA - raw data array returned by JPLEPHREAD.  Users should not
;             modify this data array.
;
;   T - ephemeris time(s) of interest, relative to TBASE (i.e. the
;       actual interpolation time is (T+TBASE)).  May be a scalar or
;       vector.
;
;   X, Y, Z - upon return, the x-, y- and z-components of the body
;             position are returned in these parameters.  For
;             nutations and librations see above.
;
;   VX, VY, VZ - upon return, the x-, y- and z-components of the body
;                velocity are returned in these parameters, if the
;                VELOCITY keyword is set.  For nutations and
;                librations see above.
;
;
; KEYWORD PARAMETERS:
;
;   EARTH, SUN - set one of these keywords if the desired body is the
;                earth or the sun.  One of EARTH, SUN or OBJECTNAME
;                must be specified.
;
;   OBJECTNAME - a scalar string or integer, specifies the planetary
;                body of interest.  May take any one of the following
;                integer or string values.
;
;                   1 - 'MERCURY'     9 - 'PLUTO'
;                   2 - 'VENUS'      10 - 'MOON'  (earth's moon)
;                   3 - 'EARTH'      11 - 'SUN'
;                   4 - 'MARS'       12 - 'SOLARBARY' or 'SSB' (solar system barycenter)
;                   5 - 'JUPITER'    13 - 'EARTHBARY' or 'EMB' (earth-moon barycenter)
;                   6 - 'SATURN'     14 - 'NUTATIONS' (see above)
;                   7 - 'URANUS'     15 - 'LIBRATIONS' (see above)
;                   8 - 'NEPTUNE' 
;
;                For custom ephemerides, the user should specify the
;                object name or number.
;
;                For augmented ephemerides, the user should specify
;                the name.  If the number is specified, then numbers
;                1-15 have the above meanings, and new objects are
;                numbered starting at 100.
;
;   CENTER - a scalar string or integer, specifies the origin of
;            coordinates.  See OBJECTNAME for allowed values.
;            Default: 12 (Solar system barycenter)
;
;   VELOCITY - if set, body velocities are generated and returned in
;              VX, VY and VZ.
;              Default: unset (no velocities)
;
;   POSUNITS - a scalar string specifying the desired units for X, Y,
;              and Z.  Allowed values:
;                 'KM' - kilometers  (default)
;                 'CM' - centimeters
;                 'AU' - astronomical units
;                 'LT-S' - light seconds
;               If angles are requested, this keyword is ignored and
;               the units are always 'RADIANS'.
;
;   VELUNITS - a scalar string specifying the desired units for VX, VY
;              and VZ.  Allowed values:
;                 'KM/DAY' - kilometers per day  (default)
;                 'KM/S' - kilometers per second
;                 'CM/S' - centimeters per second
;                 'LT-S/S' or 'V/C' - light seconds per second or
;                     unitless ratio with speed of light, V/C
;                 'AU/DAY' - astronomical units per day
;
;   TBASE - a scalar or vector, specifies a fixed epoch against wich T
;           is measured.  The ephemeris time will be (T+TBASE).  Use
;           this keyword for maximum precision.
;
;
; EXAMPLE:
;
;   Find position of earth at ephemeris time 2451544.5 JD.  Units are
;   in Astronomical Units.
;
;   JPLEPHREAD, 'JPLEPH.200', pinfo, pdata, [2451544D, 2451545D]
;
;   JPLEPHINTERP, pinfo, pdata, 2451544.5D, xearth, yearth, zearth, $
;                 /EARTH, posunits='AU'
;     
;
; REFERENCES:
;
;   AXBARY, Arnold Rots.
;      ftp://heasarc.gsfc.nasa.gov/xte/calib_data/clock/bary/
;
;   HORIZONS, JPL Web-based ephermis calculator (Ephemeris DE406)
;      http://ssd.jpl.nasa.gov/horizons.html
;   
;   Fairhead, L. & Bretagnon, P. 1990, A&A, 229, 240
;
;   Fukushima, T. 1995, A&A, 294, 895
;
;   Standish, E.M. 1982, "Orientation of the JPL Ephemerides,
;      DE200/LE200, to the Dynamical Equinox of J2000", Astronomy &
;      Astrophysics, vol. 114, pp. 297-302.
;
;   Standish, E.M.: 1990, "The Observational Basis for JPL's DE200,
;      the planetary ephemeris of the Astronomical Almanac", Astronomy
;      & Astrophysics, vol. 233, pp. 252-271.    
;
; SEE ALSO
;   JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST, TDB2TDT, JPLEPHMAKE
;   
; MODIFICATION HISTORY:
;   Written and Documented, CM, Jun 2001
;   Corrected bug in name conversion of NUTATIONS and LIBRATIONS, 18
;     Oct 2001, CM
;   Added code to handle custom-built ephemerides, 04 Mar 2002, CM
;   Fix bug in evaluation of velocity (only appears in highest order
;     polynomial term); JPLEPHTEST verification tests still pass;
;     change is of order < 0.5 cm in position, 22 Nov 2004, CM
;   Perform more validity checking on inputs; and more informative
;     outputs, 09 Oct 2008, CM
;   Allow SSB and EMB as shortcuts for solar system and earth-moon
;     bary center, 15 Oct 2008, CM
;   TBASE now allowed to be a vector or scalar, 01 Jan 2009, CM
;   VELFAC keyword gives scale factor between POSUNITS and VELUNITS, 
;     12 Jan 2009, CM
;   Add option VELUNITS='V/C' for unitless ratio with speed of light,
;     2012-10-02, CM
;
;  $Id: jplephinterp.pro,v 1.19 2012/10/02 11:32:59 cmarkwar Exp $
;
;-
; Copyright (C) 2001, 2002, 2004, 2008, 2009, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy and distribute unmodified copies for
; non-commercial purposes, and to modify and use for personal or
; internal use, is granted.  All other rights are reserved.
;-
;+
; NAME:
;   JPLEPHMAKE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Make a new ephemeris suitable for interpolation by JPLEPHINTERP
;
; MAJOR TOPICS:
;   Planetary Orbits, Interpolation
;
; CALLING SEQUENCE:
;   JPLEPHREAD, INFO, RAW, OBJ, T, CX, CY, CZ, $
;               [ POSUNITS=, AUTHOR=, DATE=, OBJECTNAME=, ]
;               [ KEYWORDS=, KEYVALUES=, /RESET ]
;
; DESCRIPTION:
;
;   JPLEPHMAKE is a utility routine which forms an ephemeris table
;   suitable for interpolation with JPLEPHINTERP.  This is a way for
;   users to make or augment an ephemeris of solar system bodies not
;   already present in the JPL planetary ephemeris.  This routine only
;   creates new ephemerides in memory.  No facility is provided to
;   write to disk.
;
;   The user must have already estimated the Chebyshev polynomial
;   coefficients for the body of interest.  One way to do this is with
;   CHEBGRID from the Markwardt library.  
;
;   The two options are either to create a new ephemeris or to augment
;   an existing one.  Augmentation merely means that new columns are
;   added to an existing ephemeris table.  The JPL ephemeris itself
;   can be augmented.
;
;   Even when creating a new ephemeris from scratch, passing an
;   existing INFO structure based on another epehemeris is strongly
;   recommended, because the structure usually contains planetary
;   masses, physical constants, etc. which are relevant.
;
;
;
; PARAMETERS: 
;
;
;   INFO - upon input, an existing INFO structure based on a known
;          ephemeris.  Upon output, a modified INFO structure.
;
;          If INFO is undefined upon input, or the RESET keyword is
;          set, then the returned INFO is set to a generic header.
;
;   RAW - upon input, an existing set of Chebyshev coefficients.  Upon
;         output, the new or augmented set of coefficients.
;
;         If RAW is undefined upon input, or if the RESET keyword is
;         set, then the returned RAW variable is initialized to a new
;         set of keywords.
;
;   OBJ - scalar string, name of the object.
;
;   T - array of times, in Julian Days (TDB), which refer to the
;       *start* epoch of each granule.  [ In the terminology of the
;       JPL ephemeris and CHEBGRID, a "granule" is a single
;       subinterval over which a Chebyshev polynomial is fitted. ] If
;       an existing ephemeris is to be augmented, then T must overlap
;       exactly.
;
;   CX, CY, CZ - arrays of Chebyshev polynomial coefficients.
;
;
;
; KEYWORD PARAMETERS:
;
;   POSUNITS - a scalar string, the units of position as fitted by CX,
;              CY, and CZ.  Allowed values:
;                 'KM' - kilometers  (default)
;                 'CM' - centimeters
;                 'AU' - astronomical units
;                 'LT-S' - light seconds
;
;   NSUBINTERVALS - Number of granules per time sample.
;                   Default: 1
;
;   RESET - if set, then a new ephemeris table is created.  Any
;           Chebyshev coefficients in RAW are overwritten.
;
;   AUTHOR - a scalar string, an identifier giving the author of the
;            new ephemeris.
;            Default: ''
;
;   DATE - a scalar string, the creation date of the ephemeris.
;          Default: SYSTIME(0)
;
;   KEYWORDS - an optional string array, giving any header keywords to
;              be added to the ephemeris (in conjunction with
;              KEYVALUES).
;              Default: (none)
;
;   KEYVALUES - an optional double array, giving any header values for
;               the keywords specified by KEYWORDS.
;
;               Default: (none)
;
;
; EXAMPLE:
;
;
; REFERENCES:
;
;   JPL Export Ephmeris FTP Site
;      ftp://navigator.jpl.nasa.gov/pub/ephem/export/
;      (ephemeris files are available here, however, they must be
;      converted to FITS format using the "bin2eph" utility found in
;      AXBARY)
;
;
; SEE ALSO
;   JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST
;   
; MODIFICATION HISTORY:
;   Written and Documented, CM, Mar 2002
;   Corrected way that ephemerides are merged, also
;     way that AUTHOR field is filled, 29 May 2002, CM
;
;  $Id: jplephmake.pro,v 1.4 2002/05/29 20:07:41 craigm Exp $
;
;-
; Copyright (C) 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy and distribute unmodified copies for
; non-commercial purposes, and to modify and use for personal or
; internal use, is granted.  All other rights are reserved.
;-
;+
; NAME:
;   JPLEPHREAD
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Open and read JPL DE200 or DE405 Ephemeride FITS File
;
; MAJOR TOPICS:
;   Planetary Orbits, Interpolation
;
; CALLING SEQUENCE:
;   JPLEPHREAD, FILENAME, INFO, RAWDATA, JDLIMITS, STATUS=, ERRMSG=
;
; DESCRIPTION:
;
;   JPLEPHREAD opens and reads the JPL DE200 or DE405 planetary
;   ephemerides, as available in FITS format.  The user must have the
;   IDL Astronomy Library installed to use this routine.
;
;   This routine is the initialization stage of a two-stage process to
;   interpolate the JPL ephemeris.  In this first stage, the file is
;   opened, and the relevant portions of the table are read and stored
;   into the two variables INFO and RAWDATA.  In the second stage, the
;   user actually interpolates the ephemeris for the desired bodies
;   and to the desired ephemeris time using JPLEPHINTERP.
;
;   Users must decide ahead of time the approximate dates of interest,
;   and pass this range in the JDLIMITS parameter.  Any date covered
;   by the ephemeris is valid.
;
;   JPLEPHREAD is able to read files of the following format:
;     DE200 - Chebyshev - FITS format - Note 1
;     DE405 - Chebyshev - FITS format - Note 1
;     DE200 - Taylor    - FITS format - Note 2
;
;   Note 1 - Chebyshev formatted FITS files are available in the
;            AXBARY package by Arnold Rots, found here:
;              ftp://heasarc.gsfc.nasa.gov/xte/calib_data/clock/bary/
;            or at the Markwardt FTP site:
;              ftp://cow.physics.wisc.edu/pub/craigm/bary/
;
;   Note 2 - Taylor-series based ephemerides have been available for
;            years in the FTOOLS / LHEASOFT package produced by NASA's
;            Goddard Space Flight Center.  The original file is
;            de200_new.fits, which covers the years 1959-2000,
;            inclusive.  A newer file is named
;            de200_1950-2050_v2.fits, and covers the years 1959-2050.
;            See Markwardt FTP site for these files.
;
; PARAMETERS: 
;
;   FILENAME - name of ephemeris file (scalar string).
;
;   INFO - upon completion, information about the ephemeris data is
;          returned in this parameter in the form of a structure.
;          Users must not modify INFO, although several fields are
;          useful and may be accessed read-only:
;              TSTART/TSTOP (start and stop time of data in Julian
;                            days);
;              C (speed of light in m/s);
;              DENUM (development ephemeris number [200 or 405])
;              AU (1 astronomical unit, in units of light-seconds)
;
;   RAWDATA - upon completion, raw ephemeris data is returned in this
;             parameter.  Users are not meant to access this data
;             directly, but rather to pass it to JPLEPHINTERP.
;
;   JDLIMITS - a two-element vector (optional), describing the desired
;              time range of interest.  The vector should have the
;              form [TSTART, TSTOP], where TSTART and TSTOP are the
;              beginning and ending times of the range, expressed in
;              Julian days.
;              Default: entire table is read (note, this can be
;              several megabytes)
;
;
; KEYWORD PARAMETERS:
;
;   STATUS - upon completion, a value of 1 indicates success, and 0
;            indicates failure.
;
;   ERRMSG - upon completion, an error message is returned in this
;            keyword.  If there were no errors, then the returned
;            value is the empty string, ''.
;
;
; EXAMPLE:
;
;   Find position of earth at ephemeris time 2451544.5 JD.  Units are
;   in Astronomical Units.
;
;   JPLEPHREAD, 'JPLEPH.200', pinfo, pdata, [2451544D, 2451545D]
;
;   JPLEPHINTERP, pinfo, pdata, 2451544.5D, xearth, yearth, zearth, $
;                 /EARTH, posunits='AU'
;     
;
; REFERENCES:
;
;   AXBARY, Arnold Rots.
;      ftp://heasarc.gsfc.nasa.gov/xte/calib_data/clock/bary/
;
;   HORIZONS, JPL Web-based ephermis calculator (Ephemeris DE406)
;      http://ssd.jpl.nasa.gov/horizons.html
;   
;   JPL Export Ephmeris FTP Site
;      ftp://navigator.jpl.nasa.gov/pub/ephem/export/
;      (ephemeris files are available here, however, they must be
;      converted to FITS format using the "bin2eph" utility found in
;      AXBARY)
;
;   JPL Export Ephemeris CD-ROM - Ordering Information
;      http://www.willbell.com/software/jpl.htm
;
;   Standish, E.M. 1982, "Orientation of the JPL Ephemerides,
;      DE200/LE200, to the Dynamical Equinox of J2000", Astronomy &
;      Astrophysics, vol. 114, pp. 297-302.
;
;   Standish, E.M.: 1990, "The Observational Basis for JPL's DE200,
;      the planetary ephemeris of the Astronomical Almanac", Astronomy
;      & Astrophysics, vol. 233, pp. 252-271.    
;
; SEE ALSO
;   JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST
;   
; MODIFICATION HISTORY:
;   Written and Documented, CM, Jun 2001
;   Incorporated changes by W. Landsman, for error handling more
;     consistent with IDL Astronomy Library, Oct 2001, WL
;   Add ephemeris file keywords to INFO, Jan 2002, CM
;   Add fields to INFO to be consistent with JPLEPHMAKE, 04 Mar 2002, CM
;   Correction of units for INFO.C (Thanks Mike Bernhardt), 2011-04-11, CM
;
;  $Id: jplephread.pro,v 1.10 2011/06/27 18:44:44 cmarkwar Exp $
;
;-
; Copyright (C) 2001, 2002, 2011, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy and distribute unmodified copies for
; non-commercial purposes, and to modify and use for personal or
; internal use, is granted.  All other rights are reserved.
;-
;  if n_elements(jdlimits) LT 2 then begin
;      errmsg = 'ERROR: You must specify JDLIMITS'
;      return
;  endif

  fxbopen, unit, filename, 1, ephhead, errmsg=errmsg
  if errmsg NE '' then $
            if printerror then message,errmsg else return

  extname = strtrim(fxpar(ephhead, 'EXTNAME'),2)
  ttype1  = strtrim(fxpar(ephhead, 'TTYPE1'),2)

  if (extname EQ 'EPHEM' AND ttype1 EQ 'EARTH') then begin
      ;; This is the DE200_NEW format (standard FTOOLS)

      nrows  = fxpar(ephhead, 'NAXIS2')
      tstart = fxpar(ephhead, 'TSTART')
      tstop  = fxpar(ephhead, 'TSTOP')
      timedel = jplephpar(ephhead, 'TIMEDEL', default=1D) ;; 1-day default

      ;; Constants from XTEBARYCEN.F
      C=2.99792458D+8
      TWOPI=6.28318530717958648D0
      DAYSEC=1.D0/86400.D0
      AULTSC=499.004782D0
      GAUSS=0.01720209895D0
      RSCHW=(GAUSS^2)*(AULTSC^3)*(DAYSEC^2)
      SUNRAD=2.315D0

      if n_elements(jdlimits) GE 2 then begin
          if (min(jdlimits) LT tstart OR $
              max(jdlimits) GT tstop) then begin
              errmsg = 'ERROR: '+filename+$
                ' does not cover the time of interest'
              fxbclose, unit
              return
          endif
          ;; Expand by one row either side
          rowlimits = floor((jdlimits-tstart)/timedel) + [-2,2]
          rowlimits = rowlimits > 1 < nrows
      endif else begin
          jdlimits  = [tstart, tstop]
          rowlimits = [1L, nrows]
      endelse

      ;; Read raw data
      fxbread, unit, cearth, 'EARTH', rowlimits, errmsg=errmsg
      if errmsg EQ '' then $
        fxbread, unit, csun, 'SUN', rowlimits, errmsg=errmsg
      if errmsg EQ '' then $
        fxbread, unit, ctdb2tdt, 'TIMEDIFF', rowlimits, errmsg=errmsg
      fxbclose, unit
      if errmsg NE '' then $
         if printerror then message,errmsg else return

      nr = rowlimits(1)-rowlimits(0)+1
      t0 = dindgen(nr)*timedel - (jdlimits(1)-jdlimits(0))/2D
      dtt = spl_init(t0, ctdb2tdt)
      raw = reform(dblarr(18, nr), 18, nr, /overwrite)
      raw(0 :11,*) = cearth * c/1000D  ;; units of lt-s
      raw(12:14,*) = csun * c/1000D    ;; units of lt-s/day
      raw(15,   *) = t0
      raw(16   ,*) = ctdb2tdt
      raw(17   ,*) = dtt

      jdlimits1 = (rowlimits+[-1,0])*timedel + tstart

      info = {filename: filename, edited: 0L, $
              creation_date: '', author: '', $
              nrows: nrows, tstart: tstart, tstop: tstop, $
              timedel: timedel, format: 'DENEW', $
              denum: 200L, c: c, emrat: 0.012150586D, $
              au: aultsc, msol: rschw, sunrad: sunrad, $
              jdlimits: jdlimits1, jdrows: nr }

  endif else if (extname EQ 'DE1' AND ttype1 EQ 'Cname') then begin
      ;; This is the BINEPH2FITS format (either DE200 or DE405)

      ;; ---------------------------------------------
      ;; First extension contains parameter data
      fxbread, unit, cname, 'Cname'
      fxbread, unit, cvalue, 'Cvalue'
      cname = strtrim(cname,2)

      denum = 0L & clight = 0D & emrat = 0D & au = 0D
      msol = 0D & radsol = 0D

      denum  = round(jplephval(cname, cvalue, 'DENUM', /fatal))
      clight = jplephval(cname, cvalue, 'CLIGHT', /fatal)    ; km/s
      emrat  = jplephval(cname, cvalue, 'EMRAT',  /fatal)
      au     = jplephval(cname, cvalue, 'AU',     /fatal)    ; km
      msol   = jplephval(cname, cvalue, 'GMS',    /fatal)    ; AU^3/day^2
      radsol = jplephval(cname, cvalue, 'RADS', default=-1D) ; km
      if radsol EQ -1D then $
        radsol = jplephval(cname, cvalue, 'ASUN', default=-1D)

      emrat = 1D / (1D + emrat)
        
      if clight EQ 0 then begin
          errmsg = 'ERROR: Could not load physical constants from '+filename
          fxbclose, unit
          return
      endif

      x = au / clight                     ;; AU (lt sec)
      msol = msol * x * x * x / 86400D^2  ;; GM_sun (in lt sec)
      radsol = radsol / clight            ;; Solar radius (lt sec)
      clight = clight * 1000              ;; Speed of light (m/s)
      
      fxbclose, unit

      ;; ---------------------------------------------
      ;; Second extension contains accounting data
      fxbopen, unit, filename, 2, ephhead, errmsg=errmsg
      if errmsg NE '' then $
            if printerror then message,errmsg else return

      extname = strtrim(fxpar(ephhead, 'EXTNAME'),2)
      if extname NE 'DE2' then begin
          errmsg = 'ERROR: '+filename+' is not a JPL ephemeris file'
          fxbclose, unit
          return
      endif

      fxbread, unit, ephobj, 'Object', errmsg=errmsg
      if errmsg EQ '' then $
        fxbread, unit, ephptr, 'Pointer', errmsg=errmsg
      if errmsg EQ '' then $
        fxbread, unit, ephncoeff, 'NumCoeff', errmsg=errmsg
      if errmsg EQ '' then $
        fxbread, unit, ephnsub, 'NumSubIntv', errmsg=errmsg
      fxbclose, unit
      if errmsg NE '' then begin
          errmsg = 'ERROR: could not read '+filename+' extension 2'
          if printerror then message,errmsg else return
      endif

      ;; Trim each object name to first word only
      for i = 0, n_elements(ephobj)-1 do begin
          ephobj(i) = strupcase((str_sep(ephobj(i), ' '))(0))
      endfor
      
      ;; ---------------------------------------------
      ;; Third extension contains Chebyshev coefficients
      fxbopen, unit, filename, 3, ephhead, errmsg=errmsg
      if errmsg NE '' then return
      extname = strtrim(fxpar(ephhead, 'EXTNAME'),2)
      if extname NE 'DE3' then begin
          errmsg = 'ERROR: '+filename+' is not a JPL ephemeris file'
          fxbclose, unit
          if printerror then message,errmsg else return
      endif
      
      nrows  = fxpar(ephhead, 'NAXIS2')
      tstart = fxpar(ephhead, 'TSTART')
      tstop  = fxpar(ephhead, 'TSTOP')
      timedel = jplephpar(ephhead, 'TIMEDEL', default=32D) ;; 32-day default

      if floor((tstop-tstart + 0.5)/timedel) NE nrows then begin
          errmsg = 'ERROR: Incorrect number of rows in '+filename
          fxbclose, unit
          if printerror then message,errmsg else return
      endif

      if n_elements(jdlimits) GE 2 then begin
          if (min(jdlimits) LT tstart OR $
              max(jdlimits) GT tstop) then begin
              errmsg = 'ERROR: '+filename+$
                ' does not cover the time of interest'
              fxbclose, unit
              if printerror then message,errmsg else return
          endif
          ;; Expand by two rows either side
          rowlimits = floor((jdlimits-tstart)/timedel) + [-2,2]
          rowlimits = rowlimits > 1 < nrows
      endif else begin
          jdlimits  = [tstart, tstop]
          rowlimits = [1L, nrows]
      endelse

      ;; Read raw data
      dims = fxbdimen(unit, 'ChebCoeffs')
      fxbread, unit, coeffs, 'ChebCoeffs', rowlimits, errmsg=errmsg
      fxbclose, unit
      if errmsg NE '' then $
         if printerror then message,errmsg else return

      raw = reform(coeffs, [dims, rowlimits(1)-rowlimits(0)+1], /overwrite)

      jdlimits1 = (rowlimits+[-1,0])*timedel + tstart
      if (abs(min(raw(0,*)) - jdlimits1(0)) GT 1d-6 OR $
          abs(max(raw(1,*)) - jdlimits1(1)) GT 1d-6) then begin
          errmsg = 'ERROR: JDLIMITS and time column do not match'
          if printerror then message,errmsg else return
      endif

      nr = rowlimits(1)-rowlimits(0)+1
      info = {filename: filename, edited: 0L, $
              creation_date: '', author: '', $
              nrows: nrows, tstart: tstart, tstop: tstop, $
              timedel: timedel, format: 'BINEPH2FITS', $
              denum: denum, c: clight, emrat: emrat, $
              au: au*1000/clight, msol: msol, sunrad: radsol, $
              jdlimits: jdlimits1, jdrows: nr, $
              objname: ephobj, ptr: ephptr, ncoeff: ephncoeff, $
              nsub: ephnsub, keywords: cname, keyvalues: cvalue}
;                 aufac: 1D/clight, velfac: 2D/(timedel*86400D), $

  endif else begin
      errmsg = 'ERROR: '+filename+' was not in a recognized format'
      fxbclose, unit
      if printerror then message,errmsg else return
  endelse

  errmsg = ''
  status = 1
  return
end
;+
; NAME:
;   JPLEPHTEST
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Test JPLEPHTEST with JPL test data set
;
; MAJOR TOPICS:
;   Planetary Orbits, Interpolation
;
; CALLING SEQUENCE:
;   JPLEPHTEST, EPHFILE, TESTFILE
;
; DESCRIPTION:
;
;   JPLEPHTEST tests the JPLEPHINTERP procedure for precision.  In
;   order to function, you must have the JPLEPHREAD and JPLEPHINTERP
;   procedures, as well as the IDL Astronomy Libary for reading FITS
;   files.  In addition, you must have a JPL ephemeris test data set,
;   which is available by FTP.
;
;   The procedure opens and reads the test set, which contains
;   precomputed data.  Every tenth value is printed on the screen.
;   Any deviations that exceed 1.5d-13 AU = 1.5 cm are reported.
;
;   The columns are labelled according to the input file, except for
;   the final column, which is the deviation between the input file
;   and the computed value.
;
;
; PARAMETERS: 
;
;   EPHFILE - a scalar string, specifies the name of the ephemeris
;             file, in FITS format.
;
;   TESTFILE - a scalar string, specifies JPL test data set to compare
;              against.
;
;   THRESHOLD - threshold (cm) above which deviations are reported as
;               too large.
;
;
; EXAMPLE:
;
;   Test JPL DE200 and DE405 ephemerides.  Assumes files are in the
;   current directory.
;
;   JPLEPHTEST, 'JPLEPH.200', 'testpo.200'
;   JPLEPHTEST, 'JPLEPH.405', 'testpo.405'
;     
;
; REFERENCES:
;
;   JPL Export Ephmeris FTP Site
;      ftp://navigator.jpl.nasa.gov/pub/ephem/export/
;      (see test-data/ for test data sets)
;   
;   HORIZONS, JPL Web-based ephermis calculator (Ephemeris DE406)
;      http://ssd.jpl.nasa.gov/horizons.html
;
;
; SEE ALSO
;   JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST
;   
; MODIFICATION HISTORY:
;   Written and Documented, CM, Jun 2001
;   Removed TRANSREAD, improved output, improved docs, CM, 9 Jul 2001
;   Add THRESHOLD keyword, CM, 30 Jan 2005
;
;  $Id: jplephtest.pro,v 1.5 2005/01/31 04:20:50 craigm Exp $
;
;-
; Copyright (C) 2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy and distribute unmodified copies for
; non-commercial purposes, and to modify and use for personal or
; internal use, is granted.  All other rights are reserved.
;-
;+
; NAME:
;   LEGCHEB
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Compute Legendre polynomial coefficents from Chebyshev coefficients
;
; MAJOR TOPICS:
;   Curve and Surface Fitting, Special Functions
;
; CALLING SEQUENCE:
;   b = LEGCHEB(a)
;
; DESCRIPTION:
;
;   This routine computes the coefficients of a Legendre polynomial
;   expansion when the Chebyshev expansion is known.
;
;   Users can determine the Chebyshev expansion coefficients using a
;   routine like CHEBFIT, CHEBCOEF or CHEBGRID.  Then, if the Legendre
;   expansion is needed instead, this conversion routine should be
;   used.  Evaluation of the Legendre series can be performed using
;   the POLYLEG function in the IDL Astronomy Library.
;
;   Internally, the computational precision is double precision.
;   This routine relies upon the algorithm of Piessens (1974).
;
; INPUTS:
;
;   A - a vector, the coefficients of the Chebyshev series of the
;       desired function.
;
; RETURNS:
;
;   The vector B, which contains the coefficients of the Legendre
;   polynomial expansion.  Both A and B will have the same number of
;   elements and data type.
;
; KEYWORD PARAMETERS:
;
;   NONE
;
; EXAMPLE:
;
;   ;; Compute the Chebyshev series coefficients of 1/(2-X) on [-1,1]
;   A = CHEBCOEF('1d/(2d - X)', /expr)
;
;   ;; Convert to Legendre series coefficients
;   B = LEGCHEB(A)
;
; REFERENCES:
;
;   Abramowitz, M. & Stegun, I., 1965, *Handbook of Mathematical
;     Functions*, 1965, U.S. Government Printing Office, Washington,
;     D.C. (Applied Mathematical Series 55)
;   Piessens, R. 1974, Comm. ACM, v. 17, p. 25 (TOMS 473)
;
; MODIFICATION HISTORY:
;   Written and documented, CM, 25 Sep 2002
;
;  $Id: legcheb.pro,v 1.1 2002/09/25 21:12:35 craigm Exp $
;
;-
; Copyright (C) 2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   LINFITEX
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Model function for fitting line with errors in X and Y
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   parms = MPFIT('LINFITEX', start_parms, $
;             FUNCTARGS={X: X, Y: Y, SIGMA_X: SIGMA_X, SIGMA_Y: SIGMA_Y}, $
;             ...)
;
; DESCRIPTION:
;
;  LINFITEX is a model function to be used with MPFIT in order to 
;  fit a line to data with errors in both "X" and "Y" directions.  
;  LINFITEX follows the methodology of Numerical Recipes, in the
;  section entitled, "Straight-Line Data with Errors in Both
;  Coordinates."
;
;  The user is not meant to call LINFITEX directly.  Rather, the
;  should pass LINFITEX as a user function to MPFIT, and MPFIT will in
;  turn call LINFITEX.
;
;  Each data point will have an X and Y position, as well as an error
;  in X and Y, denoted SIGMA_X and SIGMA_Y.  The user should pass
;  these values using the FUNCTARGS convention, as shown above.  I.e.
;  the FUNCTARGS keyword should be set to a single structure
;  containing the fields "X", "Y", "SIGMA_X" and "SIGMA_Y".  Each
;  field should have a vector of the same length.
;
;  Upon return from MPFIT, the best fit parameters will be,
;      P[0] - Y-intercept of line on the X=0 axis.
;      P[1] - slope of the line
;
;  NOTE that LINFITEX requires that AUTODERIVATIVE=1, i.e. MPFIT
;  should compute the derivatives associated with each parameter
;  numerically.
;
; INPUTS:
;   P - parameters of the linear model, as described above.
;
; KEYWORD INPUTS:
;   (as described above, these quantities should be placed in
;    a FUNCTARGS structure)
;   X - vector, X position of each data point
;   Y - vector, Y position of each data point
;   SIGMA_X - vector, X uncertainty of each data point
;   SIGMA_Y - vector, Y uncertainty of each data point
;
; RETURNS:
;   Returns a vector of residuals, of the same size as X.
;
; EXAMPLE:
;   
;   ; X and Y values
;   XS = [2.9359964E-01,1.0125043E+00,2.5900450E+00,2.6647639E+00,3.7756164E+00,4.0297413E+00,4.9227958E+00,6.4959011E+00]
;   YS = [6.0932738E-01,1.3339731E+00,1.3525699E+00,1.4060204E+00,2.8321848E+00,2.7798350E+00,2.0494456E+00,3.3113062E+00]
;   
;   ; X and Y errors
;   XE = [1.8218818E-01,3.3440986E-01,3.7536234E-01,4.5585755E-01,7.3387712E-01,8.0054945E-01,6.2370265E-01,6.7048335E-01]
;   YE = [8.9751285E-01,6.4095122E-01,1.1858428E+00,1.4673588E+00,1.0045623E+00,7.8527629E-01,1.2574003E+00,1.0080348E+00]
;
;   ; Best fit line
;   p = mpfit('LINFITEX', [1d, 1d], $
;                FUNCTARGS={X: XS, Y: YS, SIGMA_X: XE, SIGMA_Y: YE}, $
;                perror=dp, bestnorm=chi2)
;   yfit = p[0] + p[1]*XS
;
;
; REFERENCES:
;
;   Press, W. H. 1992, *Numerical Recipes in C*, 2nd Ed., Cambridge
;      University Press
;
; MODIFICATION HISTORY:
;   Written, Feb 2009
;   Documented, 14 Apr 2009, CM
;  $Id: linfitex.pro,v 1.3 2009/04/15 04:17:52 craigm Exp $
;
;-
; Copyright (C) 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;

function linfitex, p, $
                   x=x, y=y, sigma_x=sigma_x, sigma_y=sigma_y, $
                   _EXTRA=extra

  a = p[0]   ;; Intercept
  b = p[1]   ;; Slope

  f = a + b*x

  resid = (y - f)/sqrt(sigma_y^2 + (b*sigma_x)^2)

  return, resid
end
;+
; NAME:
;   LITMSOL
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Solve the light-time equation between two moving bodies
;
; MAJOR TOPICS:
;   Geometry, Physics
;
; CALLING SEQUENCE:
;   LITMSOL, T1, X1, Y1, Z1, T2, INFO2, RAW2, OBJ2, INFOSUN, RAWSUN, $
;            /RECEIVER, TBASE=, TOLERANCE=, POSUNITS=, MAXITER=, $
;            /NO_SHAPIRO
;
; DESCRIPTION:
;
;  The procedure LITMSOL solves the light time equation between two
;  moving bodies in the solar system.  Given the time and position of
;  reception or transmission of a photon, this equation determines the
;  time of transmission or reception at the other solar system body.
;  Since both bodies may be moving, the equation must be solved
;  iteratively.
;
;  The trajectories of solar system bodies must be described by either
;  a JPL ephemeris, or by a JPL-like ephemeris generated by
;  JPLEPHMAKE.  This routine calls JPLEPHINTERP.
;
;  The user specifies the known time and position of interaction as
;  T1, X1, Y1 and Z1, in units of POSUNITS.  The time of interaction
;  at the other body -- the solution to the light time equation -- is
;  returned as T2.  If the photon was *received* at time T1, then the
;  RECEIVER keyword should be set (in which case the transmission must
;  have occurred in the past).
;
;  Since the solution is iterative, the user may specify a solution
;  tolerance, and a maximum number of iterations.
;
;  If users wish to include the Shapiro time delay, which has a
;  maximum amplitude of approximately 250 usec, they must specify the
;  ephemeris of the Sun (INFOSUN, RAWSUN).  The Shapiro delay is the
;  extra general relativistic delay caused by the Sun's potential.
;
;
; INPUTS:
;
;   T1 - epoch of interaction, in Julian days, in the TDB timescale.
;        (scalar or vector)
;
;   X1, Y1, Z1 - coordinates of interaction, referred to the solar
;                system barycenter, in J2000 coordinates.  Units are
;                described by POSUNITS. (scalar or vector)
;
;   INFO2, RAW2 - ephemeris of other solar system body, returned by
;                 JPLEPHREAD or JPLEPHMAKE.
;
;   INFOSUN, RAWSUN - ephemeris of at least the Sun, as returned by
;                     JPLEPHREAD.  Only used of NO_SHAPIRO is not set.
;
;
; OUTPUTS:
;
;   T2 - upon output, epoch of interaction at the second solar system
;        body, in Julian days, in the TDB timescale.
;
;
; KEYWORD PARAMETERS:
;
;   RECEIVER - if set, then the epoch T1 is a reception of a photon.
;              Otherwise T1 is the epoch of transmission of a photon.
;
;   VX1, VY1, VZ1 - upon input, the body velocity at time T1, in
;                   VELUNITS units.  This information is required only
;                   if the SHAPIRO_DERIV is required.
;
;   X2, Y2, Z2 - upon return, the body position at time T2, in
;                POSUNITS units.
;   VX2, VY2, VZ2 - upon return, the body velocity at time T2, in
;                VELUNITS units.
;
;   TBASE - a fixed epoch time (Julian days) to be added to each value
;           of T1.  Since subtraction of large numbers occurs with
;           TBASE first, the greatest precision is achieved when TBASE
;           is expressed as a nearby julian epoch, T1 is expressed
;           as a small offset from the fixed epoch.  
;           Default: 0
;
;   POSUNITS - the units for positions, one of 'CM', 'KM', 'LT-S' or
;              'AU'.
;              Default: 'CM'
;   VELUNITS - the units for velocities (and Shapiro derivative).
;              Default: POSUNITS+'/S'
;
;   TOLERANCE - the solution tolerance, expressed in POSUNITS.
;               Default: 1000 CM
;
;   ERROR - upon return, a vector giving the estimated error in the
;           solution for each point, expressed in POSUNITS.  This
;           quantity should be less than TOLERANCE unless the number
;           of iterations exceeded MAXITER.
;
;   MAXITER - maximum number of solution iterations to be taken.
;             Default: 5
;   NITER - upon return, contains the actual number of iterations used.
;
;   SHAPIRO_CALC - method of calculating Shapiro delay, a string with
;                  one value of 'NONE', 'DELAY' or 'BOTH'.  NONE means
;                  do not calculate any Shapiro delay values.  DELAY
;                  means calculate Shapiro delay only.  BOTH means
;                  calculate the delay *and* its derivative with
;                  respect to time.  If SHAPIRO_CALC is set to
;                  DELAY or BOTH, then INFOSUN and RAWSUN must be
;                  specified.  If BOTH, then VX1, VY1 and VZ1 must
;                  also be specified. This keyword overrides
;                  NO_SHAPIRO.
;   NO_SHAPIRO - if set, then the Shapiro delay will not be accounted
;                for.  Use SHAPIRO_CALC instead.
;   SHAPIRO_DELAY - upon return, contains the Shapiro delay in
;                   seconds, if SHAPIRO_CALC is set to 'DELAY' or
;                   'BOTH'.
;   SHAPIRO_DERIV - upon return, contains the derivative of the
;                   Shapiro delay, in light seconds per time unit of
;                   velocity (SHAPIRO_CALC must be set to 'BOTH' to
;                   enable this calculation).  Note that you must
;                   supply VX1, VY1 and VZ1 to get the derivative
;                   value.
;
;
; EXAMPLE:
;
;
;
; SEE ALSO:
;
;   JPLEPHREAD, JPLEPHINTERP
;
;
; MODIFICATION HISTORY:
;   Written, 6 May 2002, CM
;   Documented, 12 May 2002, CM
;   Added TGUESS keyword, 29 May 2002, CM
;   Added ERROR and X/Y/ZOFF keywords, 25 Sep 2002, CM
;   Extensive revisions: addition of SHAPIRO_{CALC,DELAY,DERIV}
;     values; input VX1, VY1 and VZ1; output X2, Y2, Z2 and VX2 VY2
;     and VZ2; and VELUNITS keyword, 07 Mar 2007, CM
;   Allow user specified function to interpolate INFO2/RAW2 via
;     INTERP_FUNC keyword, 09 Oct 2008, CM
;
;  $Id: litmsol.pro,v 1.7 2008/10/10 00:50:19 craigm Exp $
;
;-
; Copyright (C) 2002, 2007, 2008, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   LITMSOL2
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Solve the light-time equation between two moving bodies
;
; MAJOR TOPICS:
;   Geometry, Physics, Dynamics
;
; CALLING SEQUENCE:
;   LITMSOL2, T1, X1, Y1, Z1, T2, $
;            FUNC2, INFO2, RAW2, FUNCTARGS=, FUNCTSAVE=, $
;            /RECEIVER, TBASE=, TOLERANCE=, POSUNITS=, MAXITER=, $
;            LIGHT_TIME=, TGUESS=, ERROR=, NITER=, $
;            VX1=, VY1=, VZ1=, $
;            X2=, Y2=, Z2=, VX2=, VY2=, VZ2=, $
;            METHOD=, $
;            DELAY_FUNCTION=, DELAY_ARG1=, DELAY_ARG2=, $
;            DELAY_FUNCTARGS=
;
; DESCRIPTION:
;
;  The procedure LITMSOL2 solves the light time equation between two
;  moving bodies, A and B, in the solar system.  Given the time and
;  position of reception or transmission of a photon at A, this
;  equation determines the time of transmission or reception at the
;  other solar system body B.  Since both bodies may be moving, the
;  equation must be solved iteratively.
;
;  The user must know the "A" endpoint of the ray, with time T1 and
;  position X1,Y1,Z1.  LITMSOL2 solves for the "B" endpoint time and
;  position T2 and X2,Y2,Z2 by propagating a light ray from one to the
;  other.
;
;  The position of the "B" body must be described as an interpolatable
;  function.  The user function FUNC2 must calculate the position (and
;  velocity) of the body at any applicable time T2, in the requested
;  units.
;
;  By default the body "A" is considered the transmitter and LITMSOL2
;  calculates the time at which body "B" receives the ray.   However,
;  if /RECEIVER is set, then body "A" is considered the receiver, and
;  LITMSOL2 calculates the time T2 in the past at which the ray must
;  have been transmitted by body "B" in order to be received by "A" at
;  time T1.
;
;  LITMSOL2 is able to estimate the T2 knowing only the time and
;  position at body "A".  However, convergence may be faster if the
;  TGUESS, METHOD and/or VX1,VY1,VZ1 keywords are used.  By default,
;  the initial guess for T2 is simply the same as T1.  A better
;  estimate can be passed in the TGUESS keyword.
;
;  If velocity information is available, then LITMSOL2 can use a
;  simple linear corrector method in order to speed convergence
;  (i.e. Newton's method).  The user should pass the velocity
;  at time T1 in the VX1,VY1,VZ1 keywords, and METHOD='CORRECTOR'.
; 
;  The user may also specify a "delay" function which estimates any
;  additional light propagation delays along the path based on the
;  current estimates of the two ray endpoints.  One such delay might
;  be the "Shapiro" delay due to general relativity.
;
;  Since the solution is iterative, the user may specify a solution
;  tolerance, and a maximum number of iterations.  An estimate of the
;  solution error is returned in the ERROR keyword.
;
; USER FUNCTIONS
;
;  The user must supply a function to interpolate the position of the
;  body at time T, which is passed in parameter FUNC2.  FUNC2, a
;  scalar string, is the name of subroutine to call which must compute
;  position of body at time T2.  The calling convention is the same as
;  JPLEPHINTERP, namely,
;
;     PRO FUNC2, INFO2, RAW2, T2, X2, Y2, Z2, VX2, VY2, VZ2, $
;       VELOCITY=, POSUNITS=, VELUNITS=, SAVE=, ...
;
;  The variables INFO2 and RAW2 are described below.  The variable T2
;  is the requested time (TDB), and the position and velocity must be
;  returned in X2,Y2,Z2, VX2,VY2,VZ2, with the requested units.  The
;  SAVE keyword can designate one keyword whose value will be returned
;  to the calling routine.  Any other keywords can be passed using the
;  _EXTRA calling convention using the FUNCTARGS keyword.
;
;  The user may also supply an optional function to compute an
;  additional delay.  The delay may be a function of the time and
;  position of both points "A" and "B".  For example, the "Shapiro
;  delay" of photons in the solar potential is one such kind of delay.
;  The calling convention is, 
;
;    DELAY = DELAY_FUNCTION(DELAY_ARG1, DELAY_ARG2, $
;               T1, X1, Y1, Z1, T2, X2, Y2, Z2, $
;               POSUNITS=, TBASE=, ...)
;
;  The returned delay must be in seconds, with the sense that a
;  positive value of DELAY indicates that the actual light travel time
;  is *longer* than the classical geometric travel time.
;
;     DELAY_ARG1, DELAY_ARG2 - can be any user-desired variables
;     T1 - same as T1 passed to LITMSOL2
;     X1,Y1,Z1 - same as passed to LITMSOL2
;     T2 - trial T2 interaction time in TDB Julian days
;     X2,Y2,Z2 - trial T2 interaction position, in POSUNITS
;     POSUNITS, TBASE - same as passed to LITMSOL2
;        ... additional keywords - passed via DELAY_FUNCTARGS
;            
; INPUTS:
;
;   T1 - epoch of interaction, in Julian days, in the TDB timescale.
;        (scalar or vector)
;
;   X1, Y1, Z1 - coordinates of interaction, referred to the solar
;                system barycenter, in J2000 coordinates.  Units are
;                described by POSUNITS. (scalar or vector)
;
;   FUNC2 - a scalar string, is the name of subroutine to call which
;           must compute position of body at time T2.
;
;   INFO2, RAW2 - arguments to the FUNC2 interpolation function.  At
;                 the very minimum, the INFO2 variable must be a
;                 structure of the form,
;                        INFO2 = {C: (speed of light in m/s), $
;                                 AU: (1 AU in light-seconds), $
;                                 ... other fields ... }
;                 The AU field is only required if POSUNITS EQ 'AU'.
;
; OUTPUTS:
;
;   T2 - upon output, epoch of interaction at the second solar system
;        body, in Julian days, in the TDB timescale.
;
; KEYWORD PARAMETERS:
;
;   DELAY_FUNCTION - user function to compute extra delay factors
;           based on the photon trajectory.  
;            
;   DELAY_ARG1,DELAY_ARG2 - arguments to the DELAY_FUNCTION.  These
;           variables are not touched by LITMSOL2, but merely passed
;           directly to DELAY_FUNCTION.
;
;   DELAY_FUNCTARGS - a single structure containing additional keyword
;           arguments passed to DELAY_FUNCTION using the _EXTRA method.
;
;   ERROR - upon return, a vector giving the estimated error in the
;           solution for each point, expressed in POSUNITS.  This
;           quantity should be less than TOLERANCE unless the number
;           of iterations exceeded MAXITER.
;
;   FUNCTARGS - a single structure containing additional keyword
;               arguments passed to FUNC2 using the _EXTRA method.
;
;   FUNCTSAVE - a named variable which will contain the results of
;               the SAVE keyword when calling FUNC2 upon return.
;
;   LIGHT_TIME - upon return, LIGHT_TIME is an array containing the
;                estimated light time for each requested time.
;
;   MAXITER - maximum number of solution iterations to be taken.
;             Default: 5
;
;   METHOD - solution method used, one of 'CONSTANT' or 'CORRECTOR'
;            The 'CONSTANT' method uses simple iteration.  The
;            'CORRECTOR' method uses a linear corrector to accelerate
;            convergence by accounting for the line of sight velocity,
;            but requires VX1, VY1, VZ1 to be passed.
;            Default: 'CONSTANT'
;
;   NITER - upon return, contains the actual number of iterations used.
;
;   POSUNITS - the units for positions, one of 'CM', 'KM', 'LT-S' or
;              'AU'.
;              Default: 'CM'
;
;   RECEIVER - if set, then the epoch T1 is a reception of a photon.
;              Otherwise T1 is the epoch of transmission of a photon.
;
;   TGUESS - a vector of the same size as T1, containing an initial
;            estimate of T2.
;            Default: LITMSOL2 uses its own estimate based on T1.
;
;   TOLERANCE - the solution tolerance, expressed in POSUNITS.
;               Default: 1000 CM
;
;   VX1, VY1, VZ1 - upon input, the body velocity at time T1, in
;                   VELUNITS units.  This information is required only
;                   if the CORRECTOR method is used.
;
;   VELUNITS - the units for velocities (and Shapiro derivative).
;              Default: POSUNITS+'/S'
;
;   X2, Y2, Z2, VX2, VY2, VZ2 - upon return, the body position and 
;            velocity at time T2, in units of POSUNITS and VELUNITS.
;
; EXAMPLE:
;
; SEE ALSO:
;
;   JPLEPHREAD, JPLEPHINTERP, SHAPDEL
;
;
; MODIFICATION HISTORY:
;   Major modifications, based on LITMSOL, 2009-01-05, CM
;   Documented, 2009-05-12, CM
;
;  $Id: litmsol2.pro,v 1.5 2010/05/04 21:01:52 craigm Exp $
;
;-
; Copyright (C) 2002, 2007, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   MASK2GTI
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Convert a gridded set of times to a set of Good Time Intervals (GTIs)
;
; CALLING SEQUENCE:
;   GTI = MASK2GTI(TIME, MASK, COUNT, INDICES=INDICES, $
;                  TIMEDEL=, GOOD=, BAD=, PRE=, POST=)
;
; DESCRIPTION: 
;
;   The function MASK2GTI accepts an array of times and mask, and
;   converts valid data into corresponding good time intervals (GTIs).
;
;   Elements of the MASK array are clustered together according to
;   whether they are "good" or not.  Contiguous segments of good
;   elements are converted to single good time intervals.  Time
;   elements are considered to be regularly spaced, so any breaks in
;   the MASK values are considered to be discontinuities.
;
;   The time array *must* be evenly spaced and sorted in ascending
;   order.  Each element of MASK must correspond to the same element
;   of TIME.  The primary difference between GTISEG and MASK2GTI is
;   that GTI2SEG allows time values to be irregularly sampled and no
;   mask is passed.  Also, MASK2GTI allows intervals to be enlarged or
;   shrunk.
;
;   It should be noted that this function is not constrained to
;   operation only on time arrays.  It should work on any
;   one-dimensional quantity with intervals.
;
; INPUTS:
;
;   TIME - an array of evenly spaced, ascending order, times.
;
;   MASK - an array of values matched to TIME.
;
;   COUNT - upon return, the number of resulting intervals.  A value
;           of zero indicates no good time intervals.
;
; KEYWORDS:
;
;   INDICES - upon return, a 2xCOUNT array of integers which give the
;             indices of samples which lie within each interval.  The
;             times TIME(INDICES(0,i) : INDICES(1,i)) fall within the
;             ith interval.
;
;   TIMEDEL - a scalar value giving the time spacing of the array.
;             Default: TIME(1)-TIME(0)
;
;   PRE - the amount each interval should be enlarged from its leading
;         edge.  A negative value indicates the interval should
;         shrink.
;         Default: 0
;
;   POST - the amount each interval should be enlarged from its
;          trailing edge.  A negative value indicates the interval
;          should shrink. 
;          Default: 0
;   
;   GOOD - the value of "good" in the input mask array.
;          Default: 1b
;
;   BAD - the value of "bad" in the input mask array.
;         Default: 0b
;
;
; RETURNS:
;
;   A new GTI array containing the enlarged or shrunken intervals.
;   The array is 2xCOUNT where COUNT is the number of resulting
;   intervals.  GTI(*,i) represents the start and stop times of
;   interval number i.  The intervals are non-overlapping and
;   time-ordered. 
;
;   If COUNT is zero then the returned array is a scalar value of
;   zero, indicating no good intervals were found.
;
; SEE ALSO:
;
;   GTI2MASK, GTITRIM, GTIMERGE, GTIWHERE
;
; MODIFICATION HISTORY:
;   Written, CM, 1997-2001
;   Documented, CM, Apr 2001
;
;  $Id: mask2gti.pro,v 1.4 2007/01/15 05:06:01 craigm Exp $
;
;-
; Copyright (C) 1997-2001, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   MCHOLDC
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Modified Cholesky Factorization of a Symmetric Matrix
;
; MAJOR TOPICS:
;   Linear Systems
;
; CALLING SEQUENCE:
;   MCHOLDC, A, D, E [, /OUTFULL, /SPARSE, /PIVOT, TAU=TAU, $
;                      PERMUTE=PERMUTE, INVPERMUTE=INVPERMUTE ]
;
; DESCRIPTION:
;
;  Given a symmetric matrix A, the MCHOLDC procedure computes the
;  factorization:
;
;     A + E   =   TRANSPOSE(U) ## D ## U
;
;  where A is the original matrix (optionally permuted if the PIVOT
;  keyword is set), U is an upper triangular matrix, D is a diagonal
;  matrix, and E is a diagonal error matrix.
;
;  The standard Cholesky factorization is only defined for a positive
;  definite symmetric matrix.  If the input matrix is positive
;  definite then the error term E will be zero upon output.  The user
;  may in fact test the positive-definiteness of their matrix by
;  factoring it and testing that all terms in E are zero.
;
;  If A is *not* positive definite, then the standard Cholesky
;  factorization is undefined.  In that case we adopt the "modified"
;  factorization strategy of Gill, Murray and Wright (p. 108), which
;  involves adding a diagonal error term to A in order to enforce
;  positive-definiteness.  The approach is optimal in the sense that
;  it attempts to minimize E, and thus disturbing A as little as
;  possible.  For optimization problems, this approximate
;  factorization can be used to find a direction of descent even when
;  the curvature is not positive definite.
;
;  The upper triangle of A is modified in place.  By default, the
;  lower triangle is left unchanged, and the matrices D and E are
;  actually returned as vectors containing only the diagonal terms.
;  However, if the keyword OUTFULL is set then full matrices are
;  returned.  This is useful when matrix multiplication will be
;  performed at the next step.
;
;  The modified Cholesky factorization is most stable when pivoting is
;  performed.  If the keyword PIVOT is set, then pivoting is performed
;  to place the diagonal terms with the largest amplitude in the next
;  row.  The permutation vectors returned in PERMUTE and INVPERMUTE
;  can be used to apply and reverse the pivoting.
;    [ i.e.,  (U(PP,*))(*,PP) applies the permutation and
;             (U(IPP,*))(*,IPP) reverses it, where PP and IPP are the
;             permutation and inverse permutation vectors. ]
;
;  If the matrix to be factored is very sparse, then setting the
;  SPARSE keyword may improve the speed of the computations.  SPARSE
;  is more costly on a dense matrix, but only grows as N^2, where as
;  the standard computation grows as N^3, where N is the rank of the
;  matrix.
;
;  If the CHOLSOL keyword is set, then the output is slightly
;  modified.  The returned matrix A that is returned is structured so
;  that it is compatible with the CHOLSOL built-in IDL routine.  This
;  involves converting A to being upper to lower triangular, and
;  multiplying by SQRT(D).  Users must be sure to check that all
;  elements of E are zero before using CHOLSOL.
;
; PARAMETERS:
;
;   A - upon input, a symmetric NxN matrix to be factored.
;       Upon output, the upper triangle of the matrix is modified to
;       contain the factorization.
;
;   D - upon output, the diagonal matrix D.
;
;   E - upon output, the diagonal error matrix E.
;
; KEYWORD PARAMETERS:
;
;   OUTFULL - if set, then A, D and E will be modified to be full IDL
;             matrices than can be matrix-multiplied.  By default,
;             only the upper triangle of A is modified, and D and E
;             are returned as vectors.
;
;   PIVOT - if set, then diagonal elements of A are pivoted into place
;           and operated on, in decrease order of their amplitude.
;           The permutation vectors are returned in the PERMUTE and
;           INVPERMUTE keywords.
;
;   PERMUTE - upon return, the permutation vector which converts a
;             vector into permuted form.
;
;   INVPERMUTE - upon return, the inverse permutation vector which
;                converts a vector from permuted form back into
;                standard form.
;
;   SPARSE - if set, then operations optimized for sparse matrices are
;            employed.  For large but very sparse matrices, this can
;            save a significant amount of computation time.
;
;   CHOLSOL - if set, then A and D are returned, suitable for input to
;             the built-in IDL routine CHOLSOL.  CHOLSOL is mutually
;             exclusive with the FULL keyword.
;
;   TAU - if set, then use the Tau factor as described in the
;         "unconventional" modified Cholesky factorization, as
;         described by Xie & Schlick.
;         Default: the unconventional technique is not used.
;
; EXAMPLE:
;
;   Example 1
;   ---------
;   a = randomn(seed, 5,5)    ;; Generate a random matrix
;   a = 0.5*(transpose(a)+a)  ;; Symmetrize it
;
;   a1 = a                    ;; Make a copy
;   mcholdc, a1, d, e, /full  ;; Factorize it
;   print, max(abs(e))        ;; This matrix is not positive definite
;
;   diff = transpose(a1) ## d ## a1 - e - a
;                             ;; Test the factorization by inverting
;                             ;; it and subtracting A
;   print, max(abs(diff))     ;; Differences are small
;
;   Example 2
;   ---------
;   Solving a problem with MCHOLDC and CHOLSOL
;
;   a = [[6E,15,55],[15E,55,225],[55E,225,979]]
;   b = [9.5E,50,237]
;
;   mcholdc, a, d, e, /cholsol  ;; Factorize matrix, compatible w/ CHOLSOL
;   if total(abs(e)) NE 0 then $
;      message, 'ERROR: Matrix A is not positive definite'
;
;   x = cholsol(a, d, b)        ;; Solve with CHOLSOL
;   print, x
;        -0.500001    -0.999999     0.500000
;   which is within 1e-6 of the true solution.
;
;
; REFERENCES:
;
;   Gill, P. E., Murray, W., & Wright, M. H. 1981
;     *Practical Optimization*, Academic Press
;   Schlick, T. & Fogelson, A., "TNPACK - A Truncated Newton
;     Minimization Package for Large- Scale Problems: I. Algorithm and
;     Usage," 1992, ACM TOMS, v. 18, p. 46-70.  (Alg. 702)
;   Xie, D. & Schlick, T., "Remark on Algorithm 702 - The Updated
;     Truncated Newton Minimization Package," 1999, ACM TOMS, v. 25,
;     p. 108-122.
;
; MODIFICATION HISTORY:
;   Written, CM, Apr 2001
;   Added CHOLSOL keyword, CM, 15 Feb 2002
;   Fix bug when computing final correction factor (thanks to Aaron
;     Adcock), CM, 13 Nov 2010
;
;  $Id: mcholdc.pro,v 1.6 2010/11/13 09:45:55 cmarkwar Exp $
;
;-
; Copyright (C) 2001, 2002, 2010, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;+
; NAME:
;   MPCHILIM
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Compute confidence limits for chi-square statistic
;
; MAJOR TOPICS:
;   Curve and Surface Fitting, Statistics
;
; CALLING SEQUENCE:
;   DELCHI = MPCHILIM(PROB, DOF, [/SIGMA, /CLEVEL, /SLEVEL ])
;
; DESCRIPTION:
;
;  The function MPCHILIM() computes confidence limits of the
;  chi-square statistic for a desired probability level.  The returned
;  values, DELCHI, are the limiting chi-squared values: a chi-squared
;  value of greater than DELCHI will occur by chance with probability
;  PROB:
;
;    P_CHI(CHI > DELCHI; DOF) = PROB
;
;  In specifying the probability level the user has three choices:
;
;    * give the confidence level (default);
;
;    * give the significance level (i.e., 1 - confidence level) and
;      pass the /SLEVEL keyword; OR
;
;    * give the "sigma" of the probability (i.e., compute the
;      probability based on the normal distribution) and pass the
;      /SIGMA keyword.
;
;  Note that /SLEVEL, /CLEVEL and /SIGMA are mutually exclusive.
;
; INPUTS:
;
;   PROB - scalar or vector number, giving the desired probability
;          level as described above.
;
;   DOF - scalar or vector number, giving the number of degrees of
;         freedom in the chi-square distribution.
;
; RETURNS:
;
;  Returns a scalar or vector of chi-square confidence limits.
;
; KEYWORD PARAMETERS:
;
;   SLEVEL - if set, then PROB describes the significance level.
;
;   CLEVEL - if set, then PROB describes the confidence level
;            (default).
;
;   SIGMA - if set, then PROB is the number of "sigma" away from the
;           mean in the normal distribution.
;
; EXAMPLES:
;
;   print, mpchilim(0.99d, 2d, /clevel)
;
;   Print the 99% confidence limit for a chi-squared of 2 degrees of
;   freedom.
;
;   print, mpchilim(5d, 2d, /sigma)
;
;   Print the "5 sigma" confidence limit for a chi-squared of 2
;   degrees of freedom.  Here "5 sigma" indicates the gaussian
;   probability of a 5 sigma event or greater. 
;       P_GAUSS(5D) = 1D - 5.7330314e-07
;
; REFERENCES:
;
;   Algorithms taken from CEPHES special function library, by Stephen
;   Moshier. (http://www.netlib.org/cephes/)
;
; MODIFICATION HISTORY:
;   Completed, 1999, CM
;   Documented, 16 Nov 2001, CM
;   Reduced obtrusiveness of common block and math error handling, 18
;     Nov 2001, CM
;   Convert to IDL 5 array syntax (!), 16 Jul 2006, CM
;   Move STRICTARR compile option inside each function/procedure, 9
;     Oct 2006
;   Add usage message, 24 Nov 2006, CM
;   Usage message with /CONTINUE, 23 Sep 2009, CM
;
;  $Id: mpchilim.pro,v 1.8 2009/09/23 20:12:46 craigm Exp $
;-
; Copyright (C) 1997-2001, 2006, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Set machine constants, once for this session.  Double precision
;; only.
pro cephes_setmachar
  COMPILE_OPT strictarr
  common cephes_machar, cephes_machar_vals
  if n_elements(cephes_machar_vals) GT 0 then return

  if (!version.release) LT 5 then dummy = check_math(1, 1)

  mch = machar(/double)
  machep = mch.eps
  maxnum = mch.xmax
  minnum = mch.xmin
  maxlog = alog(mch.xmax)
  minlog = alog(mch.xmin)
  maxgam = 171.624376956302725D

  cephes_machar_vals = {machep: machep, maxnum: maxnum, minnum: minnum, $
                        maxlog: maxlog, minlog: minlog, maxgam: maxgam}

  if (!version.release) LT 5 then dummy = check_math(0, 0)
  return
end

function cephes_polevl, x, coef
  COMPILE_OPT strictarr
  ans = coef[0]
  nc  = n_elements(coef)
  for i = 1L, nc-1 do ans = ans * x + coef[i]
  return, ans
end

function cephes_ndtri, y0
;   
;   	Inverse of Normal distribution function
;   
;   
;   
;    SYNOPSIS:
;   
;    double x, y, ndtri();
;   
;    x = ndtri( y );
;   
;   
;   
;    DESCRIPTION:
;   
;    Returns the argument, x, for which the area under the
;    Gaussian probability density function (integrated from
;    minus infinity to x) is equal to y.
;   
;   
;    For small arguments 0 < y < exp(-2), the program computes
;    z = sqrt( -2.0 * log(y) );  then the approximation is
;    x = z - log(z)/z  - (1/z) P(1/z) / Q(1/z).
;    There are two rational functions P/Q, one for 0 < y < exp(-32)
;    and the other for y up to exp(-2).  For larger arguments,
;    w = y - 0.5, and  x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)).
;   
;   
;    ACCURACY:
;   
;                         Relative error:
;    arithmetic   domain        # trials      peak         rms
;       DEC      0.125, 1         5500       9.5e-17     2.1e-17
;       DEC      6e-39, 0.135     3500       5.7e-17     1.3e-17
;       IEEE     0.125, 1        20000       7.2e-16     1.3e-16
;       IEEE     3e-308, 0.135   50000       4.6e-16     9.8e-17
;   
;   
;    ERROR MESSAGES:
;   
;      message         condition    value returned
;    ndtri domain       x <= 0        -MAXNUM
;    ndtri domain       x >= 1         MAXNUM
  COMPILE_OPT strictarr
  common cephes_ndtri_data, s2pi, p0, q0, p1, q1, p2, q2

  if n_elements(s2pi) EQ 0 then begin
      s2pi = sqrt(2.D*!dpi)
      p0 = [ -5.99633501014107895267D1,  9.80010754185999661536D1, $
             -5.66762857469070293439D1,  1.39312609387279679503D1, $
             -1.23916583867381258016D0 ]
      q0 = [ 1.D, $
             1.95448858338141759834D0,   4.67627912898881538453D0, $
             8.63602421390890590575D1,  -2.25462687854119370527D2, $
             2.00260212380060660359D2,  -8.20372256168333339912D1, $
             1.59056225126211695515D1,  -1.18331621121330003142D0  ]
      p1 = [ 4.05544892305962419923D0,   3.15251094599893866154D1, $
             5.71628192246421288162D1,   4.40805073893200834700D1, $
             1.46849561928858024014D1,   2.18663306850790267539D0, $
             -1.40256079171354495875D-1,-3.50424626827848203418D-2,$
             -8.57456785154685413611D-4  ]
      q1 = [ 1.D, $
             1.57799883256466749731D1,   4.53907635128879210584D1, $
             4.13172038254672030440D1,   1.50425385692907503408D1, $
             2.50464946208309415979D0,  -1.42182922854787788574D-1,$
             -3.80806407691578277194D-2,-9.33259480895457427372D-4 ]
      p2 = [  3.23774891776946035970D0,  6.91522889068984211695D0, $
              3.93881025292474443415D0,  1.33303460815807542389D0, $
              2.01485389549179081538D-1, 1.23716634817820021358D-2,$
              3.01581553508235416007D-4, 2.65806974686737550832D-6,$
              6.23974539184983293730D-9 ]
      q2 = [  1.D, $
              6.02427039364742014255D0,  3.67983563856160859403D0, $
              1.37702099489081330271D0,  2.16236993594496635890D-1,$
              1.34204006088543189037D-2, 3.28014464682127739104D-4,$
              2.89247864745380683936D-6, 6.79019408009981274425D-9]
  endif

  common cephes_machar, machvals
  MAXNUM = machvals.maxnum

  if y0 LE 0 then begin
      message, 'ERROR: domain', /info
      return, -MAXNUM
  endif
  if y0 GE 1 then begin
      message, 'ERROR: domain', /info
      return, MAXNUM
  endif

  code = 1
  y = y0
  exp2 = exp(-2.D)
  if y GT (1.D - exp2) then begin
      y = 1.D - y
      code = 0
  endif
  if y GT exp2 then begin
      y = y - 0.5
      y2 = y * y
      x = y + y * y2 * cephes_polevl(y2, p0) / cephes_polevl(y2, q0)
      x = x * s2pi
      return, x
  endif
  
  x = sqrt( -2.D * alog(y))
  x0 = x - alog(x)/x
  z = 1.D/x
  if x LT 8. then $
    x1 = z * cephes_polevl(z, p1) / cephes_polevl(z, q1) $
  else $
    x1 = z * cephes_polevl(z, p2) / cephes_polevl(z, q2)

  x = x0 - x1
  if code NE 0 then x = -x
  return, x
end

function cephes_igam, a, x
;   
;   	Incomplete gamma integral
;   
;   
;   
;    SYNOPSIS:
;   
;    double a, x, y, igam();
;   
;    y = igam( a, x );
;   
;    DESCRIPTION:
;   
;    The function is defined by
;   
;                              x
;                               -
;                      1       | |  -t  a-1
;     igam(a,x)  =   -----     |   e   t   dt.
;                     -      | |
;                    | (a)    -
;                              0
;   
;   
;    In this implementation both arguments must be positive.
;    The integral is evaluated by either a power series or
;    continued fraction expansion, depending on the relative
;    values of a and x.
;   
;    ACCURACY:
;   
;                         Relative error:
;    arithmetic   domain     # trials      peak         rms
;       IEEE      0,30       200000       3.6e-14     2.9e-15
;       IEEE      0,100      300000       9.9e-14     1.5e-14
  COMPILE_OPT strictarr
  common cephes_machar, machvals
  MAXLOG = machvals.maxlog
  MACHEP = machvals.machep

  if x LE 0 OR a LE 0 then return, 0.D
  if x GT 1. AND x GT a then return, 1.D - cephes_igamc(a, x)
  
  ax = a * alog(x) - x - lngamma(a)
  if ax LT -MAXLOG then begin
;      message, 'WARNING: underflow', /info
      return, 0.D
  endif
  ax = exp(ax)
  r = a
  c = 1.D
  ans = 1.D
  
  repeat begin
      r = r + 1
      c = c * x/r
      ans = ans + c
  endrep until (c/ans LE MACHEP)

  return, ans*ax/a
end

function cephes_igamc, a, x
;   
;   	Complemented incomplete gamma integral
;   
;   
;   
;    SYNOPSIS:
;   
;    double a, x, y, igamc();
;   
;    y = igamc( a, x );
;   
;    DESCRIPTION:
;   
;    The function is defined by
;   
;   
;     igamc(a,x)   =   1 - igam(a,x)
;   
;                               inf.
;                                 -
;                        1       | |  -t  a-1
;                  =   -----     |   e   t   dt.
;                       -      | |
;                      | (a)    -
;                                x
;   
;   
;    In this implementation both arguments must be positive.
;    The integral is evaluated by either a power series or
;    continued fraction expansion, depending on the relative
;    values of a and x.
;   
;    ACCURACY:
;   
;    Tested at random a, x.
;                   a         x                      Relative error:
;    arithmetic   domain   domain     # trials      peak         rms
;       IEEE     0.5,100   0,100      200000       1.9e-14     1.7e-15
;       IEEE     0.01,0.5  0,100      200000       1.4e-13     1.6e-15

  COMPILE_OPT strictarr
  common cephes_machar, machvals
  MAXLOG = machvals.maxlog
  MACHEP = machvals.machep

  big = 4.503599627370496D15
  biginv = 2.22044604925031308085D-16

  if x LE 0 OR a LE 0 then return, 1.D
  if x LT 1. OR x LT a then return, 1.D - cephes_igam(a, x)
  ax = a * alog(x) - x - lngamma(a)

  if ax LT -MAXLOG then begin
;      message, 'ERROR: underflow', /info
      return, 0.D
  endif
  
  ax = exp(ax)
  y = 1.D - a
  z = x + y + 1.D
  c = 0.D
  pkm2 = 1.D
  qkm2 = x
  pkm1 = x + 1.D
  qkm1 = z * x
  ans = pkm1 / qkm1

  repeat begin
      c = c + 1.D
      y = y + 1.D
      z = z + 2.D
      yc = y * c
      pk = pkm1 * z - pkm2 * yc
      qk = qkm1 * z - qkm2 * yc
      if qk NE 0 then begin
          r = pk/qk
          t = abs( (ans-r)/r )
          ans = r
      endif else begin
          t = 1.D
      endelse
      pkm2 = pkm1
      pkm1 = pk
      qkm2 = qkm1
      qkm1 = qk
      if abs(pk) GT big then begin
          pkm2 = pkm2 * biginv
          pkm1 = pkm1 * biginv
          qkm2 = qkm2 * biginv
          qkm1 = qkm1 * biginv
      endif
  endrep until t LE MACHEP

  return, ans * ax
end
  
function cephes_igami, a, y0
;  
;        Inverse of complemented imcomplete gamma integral
;  
;  
;  
;   SYNOPSIS:
;  
;   double a, x, p, igami();
;  
;   x = igami( a, p );
;  
;   DESCRIPTION:
;  
;   Given p, the function finds x such that
;  
;    igamc( a, x ) = p.
;  
;   Starting with the approximate value
;  
;           3
;    x = a t
;  
;    where
;  
;    t = 1 - d - ndtri(p) sqrt(d)
;   
;   and
;  
;    d = 1/9a,
;  
;   the routine performs up to 10 Newton iterations to find the
;   root of igamc(a,x) - p = 0.
;  
;   ACCURACY:
;  
;   Tested at random a, p in the intervals indicated.
;  
;                  a        p                      Relative error:
;   arithmetic   domain   domain     # trials      peak         rms
;      IEEE     0.5,100   0,0.5       100000       1.0e-14     1.7e-15
;      IEEE     0.01,0.5  0,0.5       100000       9.0e-14     3.4e-15
;      IEEE    0.5,10000  0,0.5        20000       2.3e-13     3.8e-14

  COMPILE_OPT strictarr
  common cephes_machar, machvals
  MAXNUM = machvals.maxnum
  MAXLOG = machvals.maxlog
  MACHEP = machvals.machep

  x0 = MAXNUM
  yl = 0.D
  x1 = 0.D
  yh = 1.D
  dithresh = 5.D * MACHEP

  d = 1.D/(9.D*a)
  y = (1.D - d - cephes_ndtri(y0) * sqrt(d))
  x = a * y * y * y
 
  lgm = lngamma(a)

  for i=0, 9 do begin
      if x GT x0 OR x LT x1 then goto, ihalve
      y = cephes_igamc(a, x)
      if y LT yl OR y GT yh then goto, ihalve
      if y LT y0 then begin
          x0 = x
          yl = y
      endif else begin
          x1 = x
          yh = y
      endelse
      
      d = (a-1.D) * alog(x) - x - lgm
      if d LT -MAXLOG then goto, ihalve
      d = -exp(d)
      d = (y - y0)/d
      if abs(d/x) LT MACHEP then goto, done
      x = x - d
  endfor

; Resort to interval halving if Newton iteration did not converge 
IHALVE:
  d = 0.0625D
  if x0 EQ MAXNUM then begin
      if x LE 0 then x = 1.D
      while x0 EQ MAXNUM do begin
          x = (1.D + d) * x
          y = cephes_igamc(a, x)
          if y LT y0 then begin
              x0 = x
              yl = y
              goto, DONELOOP1
          endif
          d = d + d
      endwhile
      DONELOOP1:
  endif

  d = 0.5
  dir = 0L
  for i=0, 399 do begin
      x = x1 + d * (x0-x1)
      y = cephes_igamc(a, x)
      lgm = (x0 - x1)/(x1 + x0)
      if abs(lgm) LT dithresh then goto, DONELOOP2
      lgm = (y - y0)/y0
      if abs(lgm) LT dithresh then goto, DONELOOP2
      if x LT 0 then goto, DONELOOP2
      if y GE y0 then begin
          x1 = x
          yh = y
          if dir LT 0 then begin
              dir = 0
              d = 0.5D
          endif else if dir GT 1 then begin
              d = 0.5 * d + 0.5
          endif else begin
              d = (y0 - yl)/(yh - yl)
          endelse
          dir = dir + 1
      endif else begin
          x0 = x
          yl = y
          if dir GT 0 then begin
              dir = 0
              d = 0.5
          endif else if dir LT -1 then begin
              d = 0.5 * d
          endif else begin
              d = (y0 - yl)/(yh - yl)
          endelse
          dir = dir - 1
      endelse
  endfor
  DONELOOP2:
  
  if x EQ 0 then begin
;      message, 'WARNING: underflow', /info
  endif

  DONE:
  return, x
end


function mpchilim, p, dof, sigma=sigma, clevel=clevel, slevel=slevel

  COMPILE_OPT strictarr

  if n_params() EQ 0 then begin
      message, 'USAGE: DELCHI = MPCHILIM(PROB, DOF, [/SIGMA, /CLEVEL, /SLEVEL ])', /cont
      return, !values.d_nan
  endif

  cephes_setmachar   ;; Set machine constants
  if n_elements(dof) EQ 0 then dof = 1.

  ;; Confidence level is the default
  if n_elements(clevel) EQ 0 then clevel = 1
  if keyword_set(sigma) then begin  ;; Significance in terms of SIGMA
      slev = 1D - errorf(p/sqrt(2.))
  endif else if keyword_set(slevel) then begin ;; in terms of SIGNIFICANCE LEVEL
      slev = p
  endif else if keyword_set(clevel) then begin ;; in terms of CONFIDENCE LEVEL
      slev = 1.D - double(p)        
  endif else begin
      message, 'ERROR: must specify one of SIGMA, CLEVEL, SLEVEL'
  endelse

  ;; Output will have same type as input
  y = p*0

  ;; Loop through, computing the inverse, incomplete gamma function
  ;; slev is the significance level
  for i = 0L, n_elements(p)-1 do begin
      y[i] = 2.D * cephes_igami(0.5D*double(dof), slev[i])
  end

  return, y
end
;+
; NAME:
;   MPCHITEST
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Compute the probability of a given chi-squared value
;
; MAJOR TOPICS:
;   Curve and Surface Fitting, Statistics
;
; CALLING SEQUENCE:
;   PROB = MPCHITEST(CHI, DOF, [/SIGMA, /CLEVEL, /SLEVEL ])
;
; DESCRIPTION:
;
;  The function MPCHITEST() computes the probability for a value drawn
;  from the chi-square distribution to equal or exceed the given value
;  CHI.  This can be used for confidence testing of a measured value
;  obeying the chi-squared distribution.
;
;    P_CHI(X > CHI; DOF) = PROB
;
;  In specifying the returned probability level the user has three
;  choices:
;
;    * return the confidence level when the /CLEVEL keyword is passed;
;      OR
;
;    * return the significance level (i.e., 1 - confidence level) when
;      the /SLEVEL keyword is passed (default); OR
;
;    * return the "sigma" of the probability (i.e., compute the
;      probability based on the normal distribution) when the /SIGMA
;      keyword is passed.
;
;  Note that /SLEVEL, /CLEVEL and /SIGMA are mutually exclusive.
;
; INPUTS:
;
;   CHI - chi-squared value to be tested.
;
;   DOF - scalar or vector number, giving the number of degrees of
;         freedom in the chi-square distribution.
;
; RETURNS:
;
;  Returns a scalar or vector of probabilities, as described above,
;  and according to the /SLEVEL, /CLEVEL and /SIGMA keywords.
;
; KEYWORD PARAMETERS:
;
;   SLEVEL - if set, then PROB describes the significance level
;            (default).
;
;   CLEVEL - if set, then PROB describes the confidence level.
;
;   SIGMA - if set, then PROB is the number of "sigma" away from the
;           mean in the normal distribution.
;
; EXAMPLES:
;
;   print, mpchitest(1300d,1252d)
;
;   Print the probability for a chi-squared value with 1252 degrees of
;   freedom to exceed a value of 1300, as a confidence level.
;
; REFERENCES:
;
;   Algorithms taken from CEPHES special function library, by Stephen
;   Moshier. (http://www.netlib.org/cephes/)
;
; MODIFICATION HISTORY:
;   Completed, 1999, CM
;   Documented, 16 Nov 2001, CM
;   Reduced obtrusiveness of common block and math error handling, 18
;     Nov 2001, CM
;   Convert to IDL 5 array syntax (!), 16 Jul 2006, CM
;   Move STRICTARR compile option inside each function/procedure, 9 Oct 2006
;   Add usage message, 24 Nov 2006, CM
;   Really add usage message, with /CONTINUE, 23 Sep 2009, CM
;
;  $Id: mpchitest.pro,v 1.10 2009/10/05 16:22:44 craigm Exp $
;-
; Copyright (C) 1997-2001, 2006, 2009, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Set machine constants, once for this session.  Double precision
;; only.
pro cephes_setmachar
  COMPILE_OPT strictarr
  common cephes_machar, cephes_machar_vals
  if n_elements(cephes_machar_vals) GT 0 then return

  if (!version.release) LT 5 then dummy = check_math(1, 1)

  mch = machar(/double)
  machep = mch.eps
  maxnum = mch.xmax
  minnum = mch.xmin
  maxlog = alog(mch.xmax)
  minlog = alog(mch.xmin)
  maxgam = 171.624376956302725D

  cephes_machar_vals = {machep: machep, maxnum: maxnum, minnum: minnum, $
                        maxlog: maxlog, minlog: minlog, maxgam: maxgam}

  if (!version.release) LT 5 then dummy = check_math(0, 0)
  return
end

function cephes_igam, a, x
;   
;   	Incomplete gamma integral
;   
;   
;   
;    SYNOPSIS:
;   
;    double a, x, y, igam();
;   
;    y = igam( a, x );
;   
;    DESCRIPTION:
;   
;    The function is defined by
;   
;                              x
;                               -
;                      1       | |  -t  a-1
;     igam(a,x)  =   -----     |   e   t   dt.
;                     -      | |
;                    | (a)    -
;                              0
;   
;   
;    In this implementation both arguments must be positive.
;    The integral is evaluated by either a power series or
;    continued fraction expansion, depending on the relative
;    values of a and x.
;   
;    ACCURACY:
;   
;                         Relative error:
;    arithmetic   domain     # trials      peak         rms
;       IEEE      0,30       200000       3.6e-14     2.9e-15
;       IEEE      0,100      300000       9.9e-14     1.5e-14
  COMPILE_OPT strictarr
  common cephes_machar, machvals
  MAXLOG = machvals.maxlog
  MACHEP = machvals.machep

  if x LE 0 OR a LE 0 then return, 0.D
  if x GT 1. AND x GT a then return, 1.D - cephes_igamc(a, x)
  
  ax = a * alog(x) - x - lngamma(a)
  if ax LT -MAXLOG then begin
;      message, 'WARNING: underflow', /info
      return, 0.D
  endif
  ax = exp(ax)
  r = a
  c = 1.D
  ans = 1.D
  
  repeat begin
      r = r + 1
      c = c * x/r
      ans = ans + c
  endrep until (c/ans LE MACHEP)

  return, ans*ax/a
end

function cephes_igamc, a, x
;   
;   	Complemented incomplete gamma integral
;   
;   
;   
;    SYNOPSIS:
;   
;    double a, x, y, igamc();
;   
;    y = igamc( a, x );
;   
;    DESCRIPTION:
;   
;    The function is defined by
;   
;   
;     igamc(a,x)   =   1 - igam(a,x)
;   
;                               inf.
;                                 -
;                        1       | |  -t  a-1
;                  =   -----     |   e   t   dt.
;                       -      | |
;                      | (a)    -
;                                x
;   
;   
;    In this implementation both arguments must be positive.
;    The integral is evaluated by either a power series or
;    continued fraction expansion, depending on the relative
;    values of a and x.
;   
;    ACCURACY:
;   
;    Tested at random a, x.
;                   a         x                      Relative error:
;    arithmetic   domain   domain     # trials      peak         rms
;       IEEE     0.5,100   0,100      200000       1.9e-14     1.7e-15
;       IEEE     0.01,0.5  0,100      200000       1.4e-13     1.6e-15

  COMPILE_OPT strictarr

  if n_params() EQ 0 then begin
      message, 'USAGE: PROB = MPCHITEST(CHI, DOF, [/SIGMA, /CLEVEL, /SLEVEL ])', /info
      return, !values.d_nan
  endif


  common cephes_machar, machvals
  MAXLOG = machvals.maxlog
  MACHEP = machvals.machep

  big = 4.503599627370496D15
  biginv = 2.22044604925031308085D-16

  if x LE 0 OR a LE 0 then return, 1.D
  if x LT 1. OR x LT a then return, 1.D - cephes_igam(a, x)
  ax = a * alog(x) - x - lngamma(a)

  if ax LT -MAXLOG then begin
;      message, 'ERROR: underflow', /info
      return, 0.D
  endif
  
  ax = exp(ax)
  y = 1.D - a
  z = x + y + 1.D
  c = 0.D
  pkm2 = 1.D
  qkm2 = x
  pkm1 = x + 1.D
  qkm1 = z * x
  ans = pkm1 / qkm1

  repeat begin
      c = c + 1.D
      y = y + 1.D
      z = z + 2.D
      yc = y * c
      pk = pkm1 * z - pkm2 * yc
      qk = qkm1 * z - qkm2 * yc
      if qk NE 0 then begin
          r = pk/qk
          t = abs( (ans-r)/r )
          ans = r
      endif else begin
          t = 1.D
      endelse
      pkm2 = pkm1
      pkm1 = pk
      qkm2 = qkm1
      qkm1 = qk
      if abs(pk) GT big then begin
          pkm2 = pkm2 * biginv
          pkm1 = pkm1 * biginv
          qkm2 = qkm2 * biginv
          qkm1 = qkm1 * biginv
      endif
  endrep until t LE MACHEP

  return, ans * ax
end

; MPCHITEST
;  compute the probability for a chi-squared value to exceed x give
;  the number of degrees of freedom dof.
function mpchitest, x, dof, slevel=slevel, clevel=clevel, sigma=sigma
  COMPILE_OPT strictarr

  if n_params() LT 2 then begin
      message, 'USAGE: PROB = MPCHITEST(CHI, DOF, [/SIGMA, /CLEVEL, /SLEVEL ])', /cont
      return, !values.d_nan
  endif

  cephes_setmachar   ;; Set machine constants
  
  p = double(x) * 0
  for i = 0, n_elements(x)-1 do begin
      p[i] = cephes_igamc(0.5D * dof, 0.5D * double(x[i]))
  endfor
  if keyword_set(clevel) then return, 1D - double(p)
  if keyword_set(sigma) then return, mpnormlim(p, /slevel)

  return, p
end

  
  
;+
; NAME:
;   MPCURVEFIT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Perform Levenberg-Marquardt least-squares fit (replaces CURVEFIT)
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   YFIT = MPCURVEFIT(X, Y, WEIGHTS, P, [SIGMA,] FUNCTION_NAME=FUNC, 
;                     ITER=iter, ITMAX=itmax, 
;                     CHISQ=chisq, NFREE=nfree, DOF=dof, 
;                     NFEV=nfev, COVAR=covar, [/NOCOVAR, ] [/NODERIVATIVE, ]
;                     FUNCTARGS=functargs, PARINFO=parinfo,
;                     FTOL=ftol, XTOL=xtol, GTOL=gtol, TOL=tol,
;                     ITERPROC=iterproc, ITERARGS=iterargs,
;                     NPRINT=nprint, QUIET=quiet, 
;                     ERRMSG=errmsg, STATUS=status)
;
; DESCRIPTION:
;
;  MPCURVEFIT fits a user-supplied model -- in the form of an IDL
;  function -- to a set of user-supplied data.  MPCURVEFIT calls
;  MPFIT, the MINPACK-1 least-squares minimizer, to do the main
;  work.
;
;  Given the data and their uncertainties, MPCURVEFIT finds the best
;  set of model parameters which match the data (in a least-squares
;  sense) and returns them in the parameter P.  
;
;  MPCURVEFIT returns the best fit function.
;  
;  The user must supply the following items:
;   - An array of independent variable values ("X").
;   - An array of "measured" *dependent* variable values ("Y").
;   - An array of weighting values ("WEIGHTS").
;   - The name of an IDL function which computes Y given X ("FUNC").
;   - Starting guesses for all of the parameters ("P").
;
;  There are very few restrictions placed on X, Y or FUNCT.  Simply
;  put, FUNCT must map the "X" values into "Y" values given the
;  model parameters.  The "X" values may represent any independent
;  variable (not just Cartesian X), and indeed may be multidimensional
;  themselves.  For example, in the application of image fitting, X
;  may be a 2xN array of image positions.
;
;  MPCURVEFIT carefully avoids passing large arrays where possible to
;  improve performance.
;
;  See below for an example of usage.
;   
; USER FUNCTION
;
;  The user must define a function which returns the model value.  For
;  applications which use finite-difference derivatives -- the default
;  -- the user function should be declared in the following way:
;
;    ; MYFUNCT - example user function
;    ;   X - input independent variable (vector same size as data)
;    ;   P - input parameter values (N-element array)
;    ;   YMOD - upon return, user function values
;    ;   DP - upon return, the user function must return
;    ;          an ARRAY(M,N) of derivatives in this parameter
;    ;
;    PRO MYFUNCT, x, p, ymod, dp
;     ymod = F(x, p)         ;; Model function
;     
;     if n_params() GE 4  then begin
;       ; Create derivative and compute derivative array
;       dp = make_array(n_elements(x), n_elements(p), value=x[0]*0)
;
;       ; Compute derivative if requested by caller
;       for i = 0, n_elements(p)-1 do dp(*,i) = FGRAD(x, p, i)
;     endif
;    END
;
;  where FGRAD(x, p, i) is a model function which computes the
;  derivative of the model F(x,p) with respect to parameter P(i) at X.
;  The returned array YMOD must have the same dimensions and type as
;  the "measured" Y values.  The returned array DP[i,j] is the
;  derivative of the ith function value with respect to the jth
;  parameter.
;
;  User functions may also indicate a fatal error condition
;  using the ERROR_CODE common block variable, as described
;  below under the MPFIT_ERROR common block definition.
; 
;  If NODERIVATIVE=1, then MPCURVEFIT will never request explicit
;  derivatives from the user function, and instead will user numerical
;  estimates (i.e. by calling the user function multiple times).
;
; CONSTRAINING PARAMETER VALUES WITH THE PARINFO KEYWORD
;
;  The behavior of MPFIT can be modified with respect to each
;  parameter to be fitted.  A parameter value can be fixed; simple
;  boundary constraints can be imposed; limitations on the parameter
;  changes can be imposed; properties of the automatic derivative can
;  be modified; and parameters can be tied to one another.
;
;  These properties are governed by the PARINFO structure, which is
;  passed as a keyword parameter to MPFIT.
;
;  PARINFO should be an array of structures, one for each parameter.
;  Each parameter is associated with one element of the array, in
;  numerical order.  The structure can have the following entries
;  (none are required):
;  
;     .VALUE - the starting parameter value (but see the START_PARAMS
;              parameter for more information).
;  
;     .FIXED - a boolean value, whether the parameter is to be held
;              fixed or not.  Fixed parameters are not varied by
;              MPFIT, but are passed on to MYFUNCT for evaluation.
;  
;     .LIMITED - a two-element boolean array.  If the first/second
;                element is set, then the parameter is bounded on the
;                lower/upper side.  A parameter can be bounded on both
;                sides.  Both LIMITED and LIMITS must be given
;                together.
;  
;     .LIMITS - a two-element float or double array.  Gives the
;               parameter limits on the lower and upper sides,
;               respectively.  Zero, one or two of these values can be
;               set, depending on the values of LIMITED.  Both LIMITED
;               and LIMITS must be given together.
;  
;     .PARNAME - a string, giving the name of the parameter.  The
;                fitting code of MPFIT does not use this tag in any
;                way.  However, the default ITERPROC will print the
;                parameter name if available.
;  
;     .STEP - the step size to be used in calculating the numerical
;             derivatives.  If set to zero, then the step size is
;             computed automatically.  Ignored when AUTODERIVATIVE=0.
;             This value is superceded by the RELSTEP value.
;
;     .RELSTEP - the *relative* step size to be used in calculating
;                the numerical derivatives.  This number is the
;                fractional size of the step, compared to the
;                parameter value.  This value supercedes the STEP
;                setting.  If the parameter is zero, then a default
;                step size is chosen.
;
;     .MPSIDE - the sidedness of the finite difference when computing
;               numerical derivatives.  This field can take four
;               values:
;
;                  0 - one-sided derivative computed automatically
;                  1 - one-sided derivative (f(x+h) - f(x)  )/h
;                 -1 - one-sided derivative (f(x)   - f(x-h))/h
;                  2 - two-sided derivative (f(x+h) - f(x-h))/(2*h)
;
;              Where H is the STEP parameter described above.  The
;              "automatic" one-sided derivative method will chose a
;              direction for the finite difference which does not
;              violate any constraints.  The other methods do not
;              perform this check.  The two-sided method is in
;              principle more precise, but requires twice as many
;              function evaluations.  Default: 0.
;
;     .MPMAXSTEP - the maximum change to be made in the parameter
;                  value.  During the fitting process, the parameter
;                  will never be changed by more than this value in
;                  one iteration.
;
;                  A value of 0 indicates no maximum.  Default: 0.
;  
;     .TIED - a string expression which "ties" the parameter to other
;             free or fixed parameters.  Any expression involving
;             constants and the parameter array P are permitted.
;             Example: if parameter 2 is always to be twice parameter
;             1 then use the following: parinfo(2).tied = '2 * P(1)'.
;             Since they are totally constrained, tied parameters are
;             considered to be fixed; no errors are computed for them.
;             [ NOTE: the PARNAME can't be used in expressions. ]
;
;     .MPPRINT - if set to 1, then the default ITERPROC will print the
;                parameter value.  If set to 0, the parameter value
;                will not be printed.  This tag can be used to
;                selectively print only a few parameter values out of
;                many.  Default: 1 (all parameters printed)
;
;  
;  Future modifications to the PARINFO structure, if any, will involve
;  adding structure tags beginning with the two letters "MP".
;  Therefore programmers are urged to avoid using tags starting with
;  the same letters; otherwise they are free to include their own
;  fields within the PARINFO structure, and they will be ignored.
;  
;  PARINFO Example:
;  parinfo = replicate({value:0.D, fixed:0, limited:[0,0], $
;                       limits:[0.D,0]}, 5)
;  parinfo(0).fixed = 1
;  parinfo(4).limited(0) = 1
;  parinfo(4).limits(0)  = 50.D
;  parinfo(*).value = [5.7D, 2.2, 500., 1.5, 2000.]
;  
;  A total of 5 parameters, with starting values of 5.7,
;  2.2, 500, 1.5, and 2000 are given.  The first parameter
;  is fixed at a value of 5.7, and the last parameter is
;  constrained to be above 50.
;
; INPUTS:
;   X - Array of independent variable values.
;
;   Y - Array of "measured" dependent variable values.  Y should have
;       the same data type as X.  The function FUNCT should map
;       X->Y.
;
;   WEIGHTS - Array of weights to be used in calculating the
;             chi-squared value.  If WEIGHTS is specified then the ERR
;             parameter is ignored.  The chi-squared value is computed
;             as follows:
;
;                CHISQ = TOTAL( (Y-FUNCT(X,P))^2 * ABS(WEIGHTS) )
;
;             Here are common values of WEIGHTS:
;
;                1D/ERR^2 - Normal weighting (ERR is the measurement error)
;                1D/Y     - Poisson weighting (counting statistics)
;                1D       - Unweighted
;
;   P - An array of starting values for each of the parameters of the
;       model.  The number of parameters should be fewer than the
;       number of measurements.  Also, the parameters should have the
;       same data type as the measurements (double is preferred).
;
;       Upon successful completion the new parameter values are
;       returned in P.
;
;       If both START_PARAMS and PARINFO are passed, then the starting
;       *value* is taken from START_PARAMS, but the *constraints* are
;       taken from PARINFO.
; 
;   SIGMA - The formal 1-sigma errors in each parameter, computed from
;           the covariance matrix.  If a parameter is held fixed, or
;           if it touches a boundary, then the error is reported as
;           zero.
;
;           If the fit is unweighted (i.e. no errors were given, or
;           the weights were uniformly set to unity), then SIGMA will
;           probably not represent the true parameter uncertainties.
;
;           *If* you can assume that the true reduced chi-squared
;           value is unity -- meaning that the fit is implicitly
;           assumed to be of good quality -- then the estimated
;           parameter uncertainties can be computed by scaling SIGMA
;           by the measured chi-squared value.
;
;              DOF     = N_ELEMENTS(X) - N_ELEMENTS(P) ; deg of freedom
;              CSIGMA  = SIGMA * SQRT(CHISQ / DOF)     ; scaled uncertainties
;
; RETURNS:
;
;   Returns the array containing the best-fitting function.
;
; KEYWORD PARAMETERS:
;
;   CHISQ - the value of the summed, squared, weighted residuals for
;           the returned parameter values, i.e. the chi-square value.
;
;   COVAR - the covariance matrix for the set of parameters returned
;           by MPFIT.  The matrix is NxN where N is the number of
;           parameters.  The square root of the diagonal elements
;           gives the formal 1-sigma statistical errors on the
;           parameters IF errors were treated "properly" in MYFUNC.
;           Parameter errors are also returned in PERROR.
;
;           To compute the correlation matrix, PCOR, use this:
;           IDL> PCOR = COV * 0
;           IDL> FOR i = 0, n-1 DO FOR j = 0, n-1 DO $
;                PCOR(i,j) = COV(i,j)/sqrt(COV(i,i)*COV(j,j))
;
;           If NOCOVAR is set or MPFIT terminated abnormally, then
;           COVAR is set to a scalar with value !VALUES.D_NAN.
;
;   DOF - number of degrees of freedom, computed as
;             DOF = N_ELEMENTS(DEVIATES) - NFREE
;         Note that this doesn't account for pegged parameters (see
;         NPEGGED).
;
;   ERRMSG - a string error or warning message is returned.
;
;   FTOL - a nonnegative input variable. Termination occurs when both
;          the actual and predicted relative reductions in the sum of
;          squares are at most FTOL (and STATUS is accordingly set to
;          1 or 3).  Therefore, FTOL measures the relative error
;          desired in the sum of squares.  Default: 1D-10
;
;   FUNCTION_NAME - a scalar string containing the name of an IDL
;                   procedure to compute the user model values, as
;                   described above in the "USER MODEL" section.
;
;   FUNCTARGS - A structure which contains the parameters to be passed
;               to the user-supplied function specified by FUNCT via
;               the _EXTRA mechanism.  This is the way you can pass
;               additional data to your user-supplied function without
;               using common blocks.
;
;               By default, no extra parameters are passed to the
;               user-supplied function.
;
;   GTOL - a nonnegative input variable. Termination occurs when the
;          cosine of the angle between fvec and any column of the
;          jacobian is at most GTOL in absolute value (and STATUS is
;          accordingly set to 4). Therefore, GTOL measures the
;          orthogonality desired between the function vector and the
;          columns of the jacobian.  Default: 1D-10
;
;   ITER - the number of iterations completed.
;
;   ITERARGS - The keyword arguments to be passed to ITERPROC via the
;              _EXTRA mechanism.  This should be a structure, and is
;              similar in operation to FUNCTARGS.
;              Default: no arguments are passed.
;
;   ITERPROC - The name of a procedure to be called upon each NPRINT
;              iteration of the MPFIT routine.  It should be declared
;              in the following way:
;
;              PRO ITERPROC, FUNCT, p, iter, fnorm, FUNCTARGS=fcnargs, $
;                PARINFO=parinfo, QUIET=quiet, ...
;                ; perform custom iteration update
;              END
;         
;              ITERPROC must either accept all three keyword
;              parameters (FUNCTARGS, PARINFO and QUIET), or at least
;              accept them via the _EXTRA keyword.
;          
;              FUNCT is the user-supplied function to be minimized,
;              P is the current set of model parameters, ITER is the
;              iteration number, and FUNCTARGS are the arguments to be
;              passed to FUNCT.  FNORM should be the
;              chi-squared value.  QUIET is set when no textual output
;              should be printed.  See below for documentation of
;              PARINFO.
;
;              In implementation, ITERPROC can perform updates to the
;              terminal or graphical user interface, to provide
;              feedback while the fit proceeds.  If the fit is to be
;              stopped for any reason, then ITERPROC should set the
;              common block variable ERROR_CODE to negative value (see
;              MPFIT_ERROR common block below).  In principle,
;              ITERPROC should probably not modify the parameter
;              values, because it may interfere with the algorithm's
;              stability.  In practice it is allowed.
;
;              Default: an internal routine is used to print the
;                       parameter values.
;
;   ITMAX - The maximum number of iterations to perform.  If the
;             number is exceeded, then the STATUS value is set to 5
;             and MPFIT returns.
;             Default: 200 iterations
;
;   NFEV - the number of FUNCT function evaluations performed.
;
;   NFREE - the number of free parameters in the fit.  This includes
;           parameters which are not FIXED and not TIED, but it does
;           include parameters which are pegged at LIMITS.
;
;   NOCOVAR - set this keyword to prevent the calculation of the
;             covariance matrix before returning (see COVAR)
;
;   NODERIVATIVE - if set, then the user function will not be queried
;                  for analytical derivatives, and instead the
;                  derivatives will be computed by finite differences
;                  (and according to the PARINFO derivative settings;
;                  see above for a description).
;
;   NPRINT - The frequency with which ITERPROC is called.  A value of
;            1 indicates that ITERPROC is called with every iteration,
;            while 2 indicates every other iteration, etc.  Note that
;            several Levenberg-Marquardt attempts can be made in a
;            single iteration.
;            Default value: 1
;
;   PARINFO - Provides a mechanism for more sophisticated constraints
;             to be placed on parameter values.  When PARINFO is not
;             passed, then it is assumed that all parameters are free
;             and unconstrained.  Values in PARINFO are never 
;             modified during a call to MPFIT.
;
;             See description above for the structure of PARINFO.
;
;             Default value:  all parameters are free and unconstrained.
;
;   QUIET - set this keyword when no textual output should be printed
;           by MPFIT
;
;   STATUS - an integer status code is returned.  All values other
;            than zero can represent success.  It can have one of the
;            following values:
;
;	   0  improper input parameters.
;         
;	   1  both actual and predicted relative reductions
;	      in the sum of squares are at most FTOL.
;         
;	   2  relative error between two consecutive iterates
;	      is at most XTOL
;         
;	   3  conditions for STATUS = 1 and STATUS = 2 both hold.
;         
;	   4  the cosine of the angle between fvec and any
;	      column of the jacobian is at most GTOL in
;	      absolute value.
;         
;	   5  the maximum number of iterations has been reached
;         
;	   6  FTOL is too small. no further reduction in
;	      the sum of squares is possible.
;         
;	   7  XTOL is too small. no further improvement in
;	      the approximate solution x is possible.
;         
;	   8  GTOL is too small. fvec is orthogonal to the
;	      columns of the jacobian to machine precision.
;
;   TOL - synonym for FTOL.  Use FTOL instead.
;
;   XTOL - a nonnegative input variable. Termination occurs when the
;          relative error between two consecutive iterates is at most
;          XTOL (and STATUS is accordingly set to 2 or 3).  Therefore,
;          XTOL measures the relative error desired in the approximate
;          solution.  Default: 1D-10
;
;   YERROR - upon return, the root-mean-square variance of the
;            residuals.
;
;
; EXAMPLE:
;
;   ; First, generate some synthetic data
;   npts = 200
;   x  = dindgen(npts) * 0.1 - 10.                  ; Independent variable 
;   yi = gauss1(x, [2.2D, 1.4, 3000.])              ; "Ideal" Y variable
;   y  = yi + randomn(seed, npts) * sqrt(1000. + yi); Measured, w/ noise
;   sy = sqrt(1000.D + y)                           ; Poisson errors
;
;   ; Now fit a Gaussian to see how well we can recover
;   p0 = [1.D, 1., 1000.]                           ; Initial guess
;   yfit = mpcurvefit(x, y, 1/sy^2, p0, $           ; Fit a function
;                     FUNCTION_NAME='GAUSS1P',/autoderivative)
;   print, p
;
;   Generates a synthetic data set with a Gaussian peak, and Poisson
;   statistical uncertainty.  Then the same function is fitted to the
;   data to see how close we can get.  GAUSS1 and GAUSS1P are
;   available from the same web page.
;
;
; COMMON BLOCKS:
;
;   COMMON MPFIT_ERROR, ERROR_CODE
;
;     User routines may stop the fitting process at any time by
;     setting an error condition.  This condition may be set in either
;     the user's model computation routine (MYFUNCT), or in the
;     iteration procedure (ITERPROC).
;
;     To stop the fitting, the above common block must be declared,
;     and ERROR_CODE must be set to a negative number.  After the user
;     procedure or function returns, MPFIT checks the value of this
;     common block variable and exits immediately if the error
;     condition has been set.  By default the value of ERROR_CODE is
;     zero, indicating a successful function/procedure call.
;
; REFERENCES:
;
;   MINPACK-1, Jorge More', available from netlib (www.netlib.org).
;   "Optimization Software Guide," Jorge More' and Stephen Wright, 
;     SIAM, *Frontiers in Applied Mathematics*, Number 14.
;
; MODIFICATION HISTORY:
;   Translated from MPFITFUN, 25 Sep 1999, CM
;   Alphabetized documented keywords, 02 Oct 1999, CM
;   Added QUERY keyword and query checking of MPFIT, 29 Oct 1999, CM
;   Check to be sure that X and Y are present, 02 Nov 1999, CM
;   Documented SIGMA for unweighted fits, 03 Nov 1999, CM
;   Changed to ERROR_CODE for error condition, 28 Jan 2000, CM
;   Copying permission terms have been liberalized, 26 Mar 2000, CM
;   Propagated improvements from MPFIT, 17 Dec 2000, CM
;   Corrected behavior of NODERIVATIVE, 13 May 2002, CM
;   Documented RELSTEP field of PARINFO (!!), CM, 25 Oct 2002
;   Make more consistent with comparable IDL routines, 30 Jun 2003, CM
;   Minor documentation adjustment, 03 Feb 2004, CM
;   Fix error in documentation, 26 Aug 2005, CM
;   Convert to IDL 5 array syntax (!), 16 Jul 2006, CM
;   Move STRICTARR compile option inside each function/procedure, 9 Oct 2006
;   Fix bug in handling of explicit derivatives with errors/weights
;     (the weights were not being applied), CM, 2012-07-22
;   Add more documentation on calling interface for user function and
;     parameter derivatives, CM, 2012-07-22
;
;  $Id: mpcurvefit.pro,v 1.11 2012/07/22 21:08:58 cmarkwar Exp $
;-
; Copyright (C) 1997-2000, 2002, 2003, 2004, 2005, 2012, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; This is the call-back function for MPFIT.  It evaluates the
; function, subtracts the data, and returns the residuals.
function mpcurvefit_eval, p, dp, _EXTRA=extra

  COMPILE_OPT strictarr
  common mpcurvefit_common, fcn, x, y, wts, f, fcnargs

  ;; The function is evaluated here.  There are four choices,
  ;; depending on whether (a) FUNCTARGS was passed to MPCURVEFIT, which
  ;; is passed to this function as "hf"; or (b) the derivative
  ;; parameter "dp" is passed, meaning that derivatives should be
  ;; calculated analytically by the function itself.
  if n_elements(fcnargs) GT 0 then begin
      if n_params() GT 1 then call_procedure, fcn, x, p, f, dp,_EXTRA=fcnargs $
      else                    call_procedure, fcn, x, p, f,    _EXTRA=fcnargs
  endif else begin
      if n_params() GT 1 then call_procedure, fcn, x, p, f, dp $
      else                    call_procedure, fcn, x, p, f
  endelse

  ;; Compute the deviates, applying the weights
  result = (y-f)*wts
  
  ;; Apply weights to derivative quantities                                     
  if n_params() GT 1 then begin
      np = n_elements(p)
      nf = n_elements(f)
      for j = 0L, np-1 do dp[j*nf] = dp[j*nf:j*nf+nf-1] * wts
  endif
      
  ;; Make sure the returned result is one-dimensional.
  result = reform(result, n_elements(result), /overwrite)
  return, result
  
end

function mpcurvefit, x, y, wts, p, perror, function_name=fcn, $
                     iter=iter, itmax=maxiter, $
                     chisq=bestnorm, nfree=nfree, dof=dof, $
                     nfev=nfev, covar=covar, nocovar=nocovar, yerror=yerror, $
                     noderivative=noderivative, tol=tol, ftol=ftol, $
                     FUNCTARGS=fa, parinfo=parinfo, $
                     errmsg=errmsg, STATUS=status, QUIET=quiet, $
                     query=query, _EXTRA=extra

  COMPILE_OPT strictarr
  status = 0L
  errmsg = ''

  ;; Detect MPFIT and crash if it was not found
  catch, catcherror
  if catcherror NE 0 then begin
      MPFIT_NOTFOUND:
      catch, /cancel
      message, 'ERROR: the required function MPFIT must be in your IDL path', /info
      return, !values.d_nan
  endif
  if mpfit(/query) NE 1 then goto, MPFIT_NOTFOUND
  catch, /cancel
  if keyword_set(query) then return, 1

  if n_params() EQ 0 then begin
      message, "USAGE: YFIT = MPCURVEFIT(X, Y, WTS, P, DP)", /info
      return, !values.d_nan
  endif
  if n_elements(x) EQ 0 OR n_elements(y) EQ 0 then begin
      message, 'ERROR: X and Y must be defined', /info
      return, !values.d_nan
  endif
  if n_elements(fcn) EQ 0 then fcn = 'funct'
  if n_elements(noderivative) EQ 0 then noderivative = 0

  common mpcurvefit_common, fc, xc, yc, wc, mc, ac
  fc = fcn & xc = x & yc = y & wc = sqrt(abs(wts)) & mc = 0L
  ac = 0 & dummy = size(temporary(ac))
  if n_elements(fa) GT 0 then ac = fa

  if n_elements(tol) GT 0 then ftol = tol

  result = mpfit('mpcurvefit_eval', p, maxiter=maxiter, $
                 autoderivative=noderivative, ftol=ftol, $
                 parinfo=parinfo, STATUS=status, nfev=nfev, BESTNORM=bestnorm,$
                 covar=covar, perror=perror, niter=iter, nfree=nfree, dof=dof,$
                 ERRMSG=errmsg, quiet=quiet, _EXTRA=extra)

  ;; Retrieve the fit value
  yfit = temporary(mc)
  ;; Now do some clean-up
  xc = 0 & yc = 0 & wc = 0 & mc = 0 & ac = 0

  if NOT keyword_set(quiet) AND errmsg NE '' then $
    message, errmsg, /info $
  else $
    p = result

  yerror = p[0]*0
  if n_elements(dof) GT 0 AND dof[0] GT 0 then begin
      yerror[0] = sqrt( total( (y-yfit)^2 ) / dof[0] )
  endif

  return, yfit
end
;+
; NAME:
;   MPFIT
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Perform Levenberg-Marquardt least-squares minimization (MINPACK-1)
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   parms = MPFIT(MYFUNCT, start_parms, FUNCTARGS=fcnargs, NFEV=nfev,
;                 MAXITER=maxiter, ERRMSG=errmsg, NPRINT=nprint, QUIET=quiet, 
;                 FTOL=ftol, XTOL=xtol, GTOL=gtol, NITER=niter, 
;                 STATUS=status, ITERPROC=iterproc, ITERARGS=iterargs,
;                 COVAR=covar, PERROR=perror, BESTNORM=bestnorm,
;                 PARINFO=parinfo)
;
; DESCRIPTION:
;
;  MPFIT uses the Levenberg-Marquardt technique to solve the
;  least-squares problem.  In its typical use, MPFIT will be used to
;  fit a user-supplied function (the "model") to user-supplied data
;  points (the "data") by adjusting a set of parameters.  MPFIT is
;  based upon MINPACK-1 (LMDIF.F) by More' and collaborators.
;
;  For example, a researcher may think that a set of observed data
;  points is best modelled with a Gaussian curve.  A Gaussian curve is
;  parameterized by its mean, standard deviation and normalization.
;  MPFIT will, within certain constraints, find the set of parameters
;  which best fits the data.  The fit is "best" in the least-squares
;  sense; that is, the sum of the weighted squared differences between
;  the model and data is minimized.
;
;  The Levenberg-Marquardt technique is a particular strategy for
;  iteratively searching for the best fit.  This particular
;  implementation is drawn from MINPACK-1 (see NETLIB), and seems to
;  be more robust than routines provided with IDL.  This version
;  allows upper and lower bounding constraints to be placed on each
;  parameter, or the parameter can be held fixed.
;
;  The IDL user-supplied function should return an array of weighted
;  deviations between model and data.  In a typical scientific problem
;  the residuals should be weighted so that each deviate has a
;  gaussian sigma of 1.0.  If X represents values of the independent
;  variable, Y represents a measurement for each value of X, and ERR
;  represents the error in the measurements, then the deviates could
;  be calculated as follows:
;
;    DEVIATES = (Y - F(X)) / ERR
;
;  where F is the function representing the model.  You are
;  recommended to use the convenience functions MPFITFUN and
;  MPFITEXPR, which are driver functions that calculate the deviates
;  for you.  If ERR are the 1-sigma uncertainties in Y, then
;
;    TOTAL( DEVIATES^2 ) 
;
;  will be the total chi-squared value.  MPFIT will minimize the
;  chi-square value.  The values of X, Y and ERR are passed through
;  MPFIT to the user-supplied function via the FUNCTARGS keyword.
;
;  Simple constraints can be placed on parameter values by using the
;  PARINFO keyword to MPFIT.  See below for a description of this
;  keyword.
;
;  MPFIT does not perform more general optimization tasks.  See TNMIN
;  instead.  MPFIT is customized, based on MINPACK-1, to the
;  least-squares minimization problem.
;
; USER FUNCTION
;
;  The user must define a function which returns the appropriate
;  values as specified above.  The function should return the weighted
;  deviations between the model and the data.  For applications which
;  use finite-difference derivatives -- the default -- the user
;  function should be declared in the following way:
;
;    FUNCTION MYFUNCT, p, X=x, Y=y, ERR=err
;     ; Parameter values are passed in "p"
;     model = F(x, p)
;     return, (y-model)/err
;    END
;
;  See below for applications with explicit derivatives.
;
;  The keyword parameters X, Y, and ERR in the example above are
;  suggestive but not required.  Any parameters can be passed to
;  MYFUNCT by using the FUNCTARGS keyword to MPFIT.  Use MPFITFUN and
;  MPFITEXPR if you need ideas on how to do that.  The function *must*
;  accept a parameter list, P.
;  
;  In general there are no restrictions on the number of dimensions in
;  X, Y or ERR.  However the deviates *must* be returned in a
;  one-dimensional array, and must have the same type (float or
;  double) as the input arrays.
;
;  See below for error reporting mechanisms.
;
;
; CHECKING STATUS AND HANNDLING ERRORS
;
;  Upon return, MPFIT will report the status of the fitting operation
;  in the STATUS and ERRMSG keywords.  The STATUS keyword will contain
;  a numerical code which indicates the success or failure status.
;  Generally speaking, any value 1 or greater indicates success, while
;  a value of 0 or less indicates a possible failure.  The ERRMSG
;  keyword will contain a text string which should describe the error
;  condition more fully.
;
;  By default, MPFIT will trap fatal errors and report them to the
;  caller gracefully.  However, during the debugging process, it is
;  often useful to halt execution where the error occurred.  When you
;  set the NOCATCH keyword, MPFIT will not do any special error
;  trapping, and execution will stop whereever the error occurred.
;
;  MPFIT does not explicitly change the !ERROR_STATE variable
;  (although it may be changed implicitly if MPFIT calls MESSAGE).  It
;  is the caller's responsibility to call MESSAGE, /RESET to ensure
;  that the error state is initialized before calling MPFIT.
;
;  User functions may also indicate non-fatal error conditions using
;  the ERROR_CODE common block variable, as described below under the
;  MPFIT_ERROR common block definition (by setting ERROR_CODE to a
;  number between -15 and -1).  When the user function sets an error
;  condition via ERROR_CODE, MPFIT will gracefully exit immediately
;  and report this condition to the caller.  The ERROR_CODE is
;  returned in the STATUS keyword in that case.
;
;
; EXPLICIT DERIVATIVES
; 
;  In the search for the best-fit solution, MPFIT by default
;  calculates derivatives numerically via a finite difference
;  approximation.  The user-supplied function need not calculate the
;  derivatives explicitly.  However, the user function *may* calculate
;  the derivatives if desired, but only if the model function is
;  declared with an additional position parameter, DP, as described
;  below.  If the user function does not accept this additional
;  parameter, MPFIT will report an error.  As a practical matter, it
;  is often sufficient and even faster to allow MPFIT to calculate the
;  derivatives numerically, but this option is available for users who
;  wish more control over the fitting process.
;
;  There are two ways to enable explicit derivatives.  First, the user
;  can set the keyword AUTODERIVATIVE=0, which is a global switch for
;  all parameters.  In this case, MPFIT will request explicit
;  derivatives for every free parameter.  
;
;  Second, the user may request explicit derivatives for specifically
;  selected parameters using the PARINFO.MPSIDE=3 (see "CONSTRAINING
;  PARAMETER VALUES WITH THE PARINFO KEYWORD" below).  In this
;  strategy, the user picks and chooses which parameter derivatives
;  are computed explicitly versus numerically.  When PARINFO[i].MPSIDE
;  EQ 3, then the ith parameter derivative is computed explicitly.
;
;  The keyword setting AUTODERIVATIVE=0 always globally overrides the
;  individual values of PARINFO.MPSIDE.  Setting AUTODERIVATIVE=0 is
;  equivalent to resetting PARINFO.MPSIDE=3 for all parameters.
;
;  Even if the user requests explicit derivatives for some or all
;  parameters, MPFIT will not always request explicit derivatives on
;  every user function call.
;
; EXPLICIT DERIVATIVES - CALLING INTERFACE
;
;  When AUTODERIVATIVE=0, the user function is responsible for
;  calculating the derivatives of the *residuals* with respect to each
;  parameter.  The user function should be declared as follows:
;
;    ;
;    ; MYFUNCT - example user function
;    ;   P - input parameter values (N-element array)
;    ;   DP - upon input, an N-vector indicating which parameters
;    ;          to compute derivatives for; 
;    ;        upon output, the user function must return
;    ;          an ARRAY(M,N) of derivatives in this keyword
;    ;   (keywords) - any other keywords specified by FUNCTARGS
;    ; RETURNS - residual values
;    ;
;    FUNCTION MYFUNCT, p, dp, X=x, Y=y, ERR=err
;     model = F(x, p)         ;; Model function
;     resid = (y - model)/err ;; Residual calculation (for example)
;     
;     if n_params() GT 1 then begin
;       ; Create derivative and compute derivative array
;       requested = dp   ; Save original value of DP
;       dp = make_array(n_elements(x), n_elements(p), value=x[0]*0)
;
;       ; Compute derivative if requested by caller
;       for i = 0, n_elements(p)-1 do if requested(i) NE 0 then $
;         dp(*,i) = FGRAD(x, p, i) / err
;     endif
;    
;     return, resid
;    END
;
;  where FGRAD(x, p, i) is a model function which computes the
;  derivative of the model F(x,p) with respect to parameter P(i) at X.
;
;  A quirk in the implementation leaves a stray negative sign in the
;  definition of DP.  The derivative of the *residual* should be
;  "-FGRAD(x,p,i) / err" because of how the residual is defined
;  ("resid = (data - model) / err").  **HOWEVER** because of the
;  implementation quirk, MPFIT expects FGRAD(x,p,i)/err instead,
;  i.e. the opposite sign of the gradient of RESID.
;
;  Derivatives should be returned in the DP array. DP should be an
;  ARRAY(m,n) array, where m is the number of data points and n is the
;  number of parameters.  -DP[i,j] is the derivative of the ith
;  residual with respect to the jth parameter (note the minus sign
;  due to the quirk described above).
;
;  As noted above, MPFIT may not always request derivatives from the
;  user function.  In those cases, the parameter DP is not passed.
;  Therefore functions can use N_PARAMS() to indicate whether they
;  must compute the derivatives or not.
;  
;  The derivatives with respect to fixed parameters are ignored; zero
;  is an appropriate value to insert for those derivatives.  Upon
;  input to the user function, DP is set to a vector with the same
;  length as P, with a value of 1 for a parameter which is free, and a
;  value of zero for a parameter which is fixed (and hence no
;  derivative needs to be calculated).  This input vector may be
;  overwritten as needed.  In the example above, the original DP
;  vector is saved to a variable called REQUESTED, and used as a mask
;  to calculate only those derivatives that are required.
;
;  If the data is higher than one dimensional, then the *last*
;  dimension should be the parameter dimension.  Example: fitting a
;  50x50 image, "dp" should be 50x50xNPAR.
;
; EXPLICIT DERIVATIVES - TESTING and DEBUGGING
;
;  For reasonably complicated user functions, the calculation of
;  explicit derivatives of the correct sign and magnitude can be
;  difficult to get right.  A simple sign error can cause MPFIT to be
;  confused.  MPFIT has a derivative debugging mode which will compute
;  the derivatives *both* numerically and explicitly, and compare the
;  results.
;
;  It is expected that during production usage, derivative debugging
;  should be disabled for all parameters.
;
;  In order to enable derivative debugging mode, set the following
;  PARINFO members for the ith parameter.
;      PARINFO[i].MPSIDE = 3          ; Enable explicit derivatives
;      PARINFO[i].MPDERIV_DEBUG = 1   ; Enable derivative debugging mode
;      PARINFO[i].MPDERIV_RELTOL = ?? ; Relative tolerance for comparison
;      PARINFO[i].MPDERIV_ABSTOL = ?? ; Absolute tolerance for comparison
;  Note that these settings are maintained on a parameter-by-parameter
;  basis using PARINFO, so the user can choose which parameters
;  derivatives will be tested.
;
;  When .MPDERIV_DEBUG is set, then MPFIT first computes the
;  derivative explicitly by requesting them from the user function.
;  Then, it computes the derivatives numerically via finite
;  differencing, and compares the two values.  If the difference
;  exceeds a tolerance threshold, then the values are printed out to 
;  alert the user.  The tolerance level threshold contains both a
;  relative and an absolute component, and is expressed as,
;
;     ABS(DERIV_U - DERIV_N) GE (ABSTOL + RELTOL*ABS(DERIV_U))
;
;  where DERIV_U and DERIV_N are the derivatives computed explicitly
;  and numerically, respectively.  Appropriate values
;  for most users will be: 
;
;      PARINFO[i].MPDERIV_RELTOL = 1d-3 ;; Suggested relative tolerance 
;      PARINFO[i].MPDERIV_ABSTOL = 1d-7 ;; Suggested absolute tolerance
;
;  although these thresholds may have to be adjusted for a particular
;  problem.  When the threshold is exceeded, users can expect to see a
;  tabular report like this one:
;
;    FJAC DEBUG BEGIN
;    #        IPNT       FUNC    DERIV_U    DERIV_N   DIFF_ABS   DIFF_REL
;    FJAC PARM 2
;               80    -0.7308    0.04233    0.04233 -5.543E-07 -1.309E-05
;               99      1.370    0.01417    0.01417 -5.518E-07 -3.895E-05
;              118    0.07187   -0.01400   -0.01400 -5.566E-07  3.977E-05
;              137      1.844   -0.04216   -0.04216 -5.589E-07  1.326E-05
;    FJAC DEBUG END
;
;  The report will be bracketed by FJAC DEBUG BEGIN/END statements.
;  Each parameter will be delimited by the statement FJAC PARM n,
;  where n is the parameter number.  The columns are,
;
;      IPNT - data point number  (0 ... M-1)
;      FUNC - function value at that point
;      DERIV_U - explicit derivative value at that point
;      DERIV_N - numerical derivative estimate at that point
;      DIFF_ABS - absolute difference = (DERIV_U - DERIV_N)
;      DIFF_REL - relative difference = (DIFF_ABS)/(DERIV_U)
;
;  When prints appear in this report, it is most important to check
;  that the derivatives computed in two different ways have the same
;  numerical sign and the same order of magnitude, since these are the
;  most common programming mistakes.
;
;  A line of this form may also appear 
;
;   # FJAC_MASK = 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 
;
;  This line indicates for which parameters explicit derivatives are
;  expected.  A list of all-1s indicates all explicit derivatives for
;  all parameters are requested from the user function.
;    
;  
; CONSTRAINING PARAMETER VALUES WITH THE PARINFO KEYWORD
;
;  The behavior of MPFIT can be modified with respect to each
;  parameter to be fitted.  A parameter value can be fixed; simple
;  boundary constraints can be imposed; limitations on the parameter
;  changes can be imposed; properties of the automatic derivative can
;  be modified; and parameters can be tied to one another.
;
;  These properties are governed by the PARINFO structure, which is
;  passed as a keyword parameter to MPFIT.
;
;  PARINFO should be an array of structures, one for each parameter.
;  Each parameter is associated with one element of the array, in
;  numerical order.  The structure can have the following entries
;  (none are required):
;  
;     .VALUE - the starting parameter value (but see the START_PARAMS
;              parameter for more information).
;  
;     .FIXED - a boolean value, whether the parameter is to be held
;              fixed or not.  Fixed parameters are not varied by
;              MPFIT, but are passed on to MYFUNCT for evaluation.
;  
;     .LIMITED - a two-element boolean array.  If the first/second
;                element is set, then the parameter is bounded on the
;                lower/upper side.  A parameter can be bounded on both
;                sides.  Both LIMITED and LIMITS must be given
;                together.
;  
;     .LIMITS - a two-element float or double array.  Gives the
;               parameter limits on the lower and upper sides,
;               respectively.  Zero, one or two of these values can be
;               set, depending on the values of LIMITED.  Both LIMITED
;               and LIMITS must be given together.
;  
;     .PARNAME - a string, giving the name of the parameter.  The
;                fitting code of MPFIT does not use this tag in any
;                way.  However, the default ITERPROC will print the
;                parameter name if available.
;  
;     .STEP - the step size to be used in calculating the numerical
;             derivatives.  If set to zero, then the step size is
;             computed automatically.  Ignored when AUTODERIVATIVE=0.
;             This value is superceded by the RELSTEP value.
;
;     .RELSTEP - the *relative* step size to be used in calculating
;                the numerical derivatives.  This number is the
;                fractional size of the step, compared to the
;                parameter value.  This value supercedes the STEP
;                setting.  If the parameter is zero, then a default
;                step size is chosen.
;
;     .MPSIDE - selector for type of derivative calculation. This
;               field can take one of five possible values:
;
;                  0 - one-sided derivative computed automatically
;                  1 - one-sided derivative (f(x+h) - f(x)  )/h
;                 -1 - one-sided derivative (f(x)   - f(x-h))/h
;                  2 - two-sided derivative (f(x+h) - f(x-h))/(2*h)
;                  3 - explicit derivative used for this parameter
;
;              In the first four cases, the derivative is approximated
;              numerically by finite difference, with step size
;              H=STEP, where the STEP parameter is defined above.  The
;              last case, MPSIDE=3, indicates to allow the user
;              function to compute the derivative explicitly (see
;              section on "EXPLICIT DERIVATIVES").  AUTODERIVATIVE=0
;              overrides this setting for all parameters, and is
;              equivalent to MPSIDE=3 for all parameters.  For
;              MPSIDE=0, the "automatic" one-sided derivative method
;              will chose a direction for the finite difference which
;              does not violate any constraints.  The other methods
;              (MPSIDE=-1 or MPSIDE=1) do not perform this check.  The
;              two-sided method is in principle more precise, but
;              requires twice as many function evaluations.  Default:
;              0.
;
;     .MPDERIV_DEBUG - set this value to 1 to enable debugging of
;              user-supplied explicit derivatives (see "TESTING and
;              DEBUGGING" section above).  In addition, the
;              user must enable calculation of explicit derivatives by
;              either setting AUTODERIVATIVE=0, or MPSIDE=3 for the
;              desired parameters.  When this option is enabled, a
;              report may be printed to the console, depending on the
;              MPDERIV_ABSTOL and MPDERIV_RELTOL settings.
;              Default: 0 (no debugging)
;
;     
;     .MPDERIV_ABSTOL, .MPDERIV_RELTOL - tolerance settings for
;              print-out of debugging information, for each parameter
;              where debugging is enabled.  See "TESTING and
;              DEBUGGING" section above for the meanings of these two
;              fields.
;
;
;     .MPMAXSTEP - the maximum change to be made in the parameter
;                  value.  During the fitting process, the parameter
;                  will never be changed by more than this value in
;                  one iteration.
;
;                  A value of 0 indicates no maximum.  Default: 0.
;  
;     .TIED - a string expression which "ties" the parameter to other
;             free or fixed parameters as an equality constraint.  Any
;             expression involving constants and the parameter array P
;             are permitted.
;             Example: if parameter 2 is always to be twice parameter
;             1 then use the following: parinfo[2].tied = '2 * P[1]'.
;             Since they are totally constrained, tied parameters are
;             considered to be fixed; no errors are computed for them,
;             and any LIMITS are not obeyed.
;             [ NOTE: the PARNAME can't be used in a TIED expression. ]
;
;     .MPPRINT - if set to 1, then the default ITERPROC will print the
;                parameter value.  If set to 0, the parameter value
;                will not be printed.  This tag can be used to
;                selectively print only a few parameter values out of
;                many.  Default: 1 (all parameters printed)
;
;     .MPFORMAT - IDL format string to print the parameter within
;                 ITERPROC.  Default: '(G20.6)'  (An empty string will
;                 also use the default.)
;
;  Future modifications to the PARINFO structure, if any, will involve
;  adding structure tags beginning with the two letters "MP".
;  Therefore programmers are urged to avoid using tags starting with
;  "MP", but otherwise they are free to include their own fields
;  within the PARINFO structure, which will be ignored by MPFIT.
;  
;  PARINFO Example:
;  parinfo = replicate({value:0.D, fixed:0, limited:[0,0], $
;                       limits:[0.D,0]}, 5)
;  parinfo[0].fixed = 1
;  parinfo[4].limited[0] = 1
;  parinfo[4].limits[0]  = 50.D
;  parinfo[*].value = [5.7D, 2.2, 500., 1.5, 2000.]
;  
;  A total of 5 parameters, with starting values of 5.7,
;  2.2, 500, 1.5, and 2000 are given.  The first parameter
;  is fixed at a value of 5.7, and the last parameter is
;  constrained to be above 50.
;
;
; RECURSION
;
;  Generally, recursion is not allowed.  As of version 1.77, MPFIT has
;  recursion protection which does not allow a model function to
;  itself call MPFIT.  Users who wish to perform multi-level
;  optimization should investigate the 'EXTERNAL' function evaluation
;  methods described below for hard-to-evaluate functions.  That
;  method places more control in the user's hands.  The user can
;  design a "recursive" application by taking care.
;
;  In most cases the recursion protection should be well-behaved.
;  However, if the user is doing debugging, it is possible for the
;  protection system to get "stuck."  In order to reset it, run the
;  procedure:
;     MPFIT_RESET_RECURSION
;  and the protection system should get "unstuck."  It is save to call
;  this procedure at any time.
;
;
; COMPATIBILITY
;
;  This function is designed to work with IDL 5.0 or greater.
;  
;  Because TIED parameters and the "(EXTERNAL)" user-model feature use
;  the EXECUTE() function, they cannot be used with the free version
;  of the IDL Virtual Machine.
;
;
; DETERMINING THE VERSION OF MPFIT
;
;  MPFIT is a changing library.  Users of MPFIT may also depend on a
;  specific version of the library being present.  As of version 1.70
;  of MPFIT, a VERSION keyword has been added which allows the user to
;  query which version is present.  The keyword works like this:
;
;    RESULT = MPFIT(/query, VERSION=version)
;
;  This call uses the /QUERY keyword to query the version number
;  without performing any computations.  Users of MPFIT can call this
;  method to determine which version is in the IDL path before
;  actually using MPFIT to do any numerical work.  Upon return, the
;  VERSION keyword contains the version number of MPFIT, expressed as
;  a string of the form 'X.Y' where X and Y are integers.
;
;  Users can perform their own version checking, or use the built-in
;  error checking of MPFIT.  The MIN_VERSION keyword enforces the
;  requested minimum version number.  For example,
;
;    RESULT = MPFIT(/query, VERSION=version, MIN_VERSION='1.70')
;
;  will check whether the accessed version is 1.70 or greater, without
;  performing any numerical processing.
;
;  The VERSION and MIN_VERSION keywords were added in MPFIT
;  version 1.70 and later.  If the caller attempts to use the VERSION
;  or MIN_VERSION keywords, and an *older* version of the code is
;  present in the caller's path, then IDL will throw an 'unknown
;  keyword' error.  Therefore, in order to be robust, the caller, must
;  use exception handling.  Here is an example demanding at least
;  version 1.70.
;
;    MPFIT_OK = 0  & VERSION = '<unknown>'
;    CATCH, CATCHERR
;    IF CATCHERR EQ 0 THEN MPFIT_OK = MPFIT(/query, VERSION=version, $
;                                         MIN_VERSION='1.70')
;    CATCH, /CANCEL
;
;    IF NOT MPFIT_OK THEN $
;      MESSAGE, 'ERROR: you must have MPFIT version 1.70 or higher in '+$
;             'your path (found version '+version+')'
;
;  Of course, the caller can also do its own version number
;  requirements checking.
;
;
; HARD-TO-COMPUTE FUNCTIONS: "EXTERNAL" EVALUATION
;
;  The normal mode of operation for MPFIT is for the user to pass a
;  function name, and MPFIT will call the user function multiple times
;  as it iterates toward a solution.
;
;  Some user functions are particularly hard to compute using the
;  standard model of MPFIT.  Usually these are functions that depend
;  on a large amount of external data, and so it is not feasible, or
;  at least highly impractical, to have MPFIT call it.  In those cases
;  it may be possible to use the "(EXTERNAL)" evaluation option.
;
;  In this case the user is responsible for making all function *and
;  derivative* evaluations.  The function and Jacobian data are passed
;  in through the EXTERNAL_FVEC and EXTERNAL_FJAC keywords,
;  respectively.  The user indicates the selection of this option by
;  specifying a function name (MYFUNCT) of "(EXTERNAL)".  No
;  user-function calls are made when EXTERNAL evaluation is being
;  used.
;
;  ** SPECIAL NOTE ** For the "(EXTERNAL)" case, the quirk noted above
;     does not apply.  The gradient matrix, EXTERNAL_FJAC, should be
;     comparable to "-FGRAD(x,p)/err", which is the *opposite* sign of
;     the DP matrix described above.  In other words, EXTERNAL_FJAC
;     has the same sign as the derivative of EXTERNAL_FVEC, and the
;     opposite sign of FGRAD.
;
;  At the end of each iteration, control returns to the user, who must
;  reevaluate the function at its new parameter values.  Users should
;  check the return value of the STATUS keyword, where a value of 9
;  indicates the user should supply more data for the next iteration,
;  and re-call MPFIT.  The user may refrain from calling MPFIT
;  further; as usual, STATUS will indicate when the solution has
;  converged and no more iterations are required.
;
;  Because MPFIT must maintain its own data structures between calls,
;  the user must also pass a named variable to the EXTERNAL_STATE
;  keyword.  This variable must be maintained by the user, but not
;  changed, throughout the fitting process.  When no more iterations
;  are desired, the named variable may be discarded.
;
;
; INPUTS:
;   MYFUNCT - a string variable containing the name of the function to
;             be minimized.  The function should return the weighted
;             deviations between the model and the data, as described
;             above.
;
;             For EXTERNAL evaluation of functions, this parameter
;             should be set to a value of "(EXTERNAL)".
;
;   START_PARAMS - An one-dimensional array of starting values for each of the
;                  parameters of the model.  The number of parameters
;                  should be fewer than the number of measurements.
;                  Also, the parameters should have the same data type
;                  as the measurements (double is preferred).
;
;                  This parameter is optional if the PARINFO keyword
;                  is used (but see PARINFO).  The PARINFO keyword
;                  provides a mechanism to fix or constrain individual
;                  parameters.  If both START_PARAMS and PARINFO are
;                  passed, then the starting *value* is taken from
;                  START_PARAMS, but the *constraints* are taken from
;                  PARINFO.
; 
; RETURNS:
;
;   Returns the array of best-fit parameters.
;   Exceptions: 
;      * if /QUERY is set (see QUERY).
;
;
; KEYWORD PARAMETERS:
;
;   AUTODERIVATIVE - If this is set, derivatives of the function will
;                    be computed automatically via a finite
;                    differencing procedure.  If not set, then MYFUNCT
;                    must provide the explicit derivatives.
;                    Default: set (=1) 
;                    NOTE: to supply your own explicit derivatives,
;                      explicitly pass AUTODERIVATIVE=0
;
;   BESTNORM - upon return, the value of the summed squared weighted
;              residuals for the returned parameter values,
;              i.e. TOTAL(DEVIATES^2).
;
;   BEST_FJAC - upon return, BEST_FJAC contains the Jacobian, or
;               partial derivative, matrix for the best-fit model.
;               The values are an array,
;               ARRAY(N_ELEMENTS(DEVIATES),NFREE) where NFREE is the
;               number of free parameters.  This array is only
;               computed if /CALC_FJAC is set, otherwise BEST_FJAC is
;               undefined.
;
;               The returned array is such that BEST_FJAC[I,J] is the
;               partial derivative of DEVIATES[I] with respect to
;               parameter PARMS[PFREE_INDEX[J]].  Note that since
;               deviates are (data-model)*weight, the Jacobian of the
;               *deviates* will have the opposite sign from the
;               Jacobian of the *model*, and may be scaled by a
;               factor.
;
;   BEST_RESID - upon return, an array of best-fit deviates.
;
;   CALC_FJAC - if set, then calculate the Jacobian and return it in
;               BEST_FJAC.  If not set, then the return value of
;               BEST_FJAC is undefined.
;
;   COVAR - the covariance matrix for the set of parameters returned
;           by MPFIT.  The matrix is NxN where N is the number of
;           parameters.  The square root of the diagonal elements
;           gives the formal 1-sigma statistical errors on the
;           parameters IF errors were treated "properly" in MYFUNC.
;           Parameter errors are also returned in PERROR.
;
;           To compute the correlation matrix, PCOR, use this example:
;                  PCOR = COV * 0
;                  FOR i = 0, n-1 DO FOR j = 0, n-1 DO $
;                    PCOR[i,j] = COV[i,j]/sqrt(COV[i,i]*COV[j,j])
;           or equivalently, in vector notation,
;                  PCOR = COV / (PERROR # PERROR)
;
;           If NOCOVAR is set or MPFIT terminated abnormally, then
;           COVAR is set to a scalar with value !VALUES.D_NAN.
;
;   DOF - number of degrees of freedom, computed as
;             DOF = N_ELEMENTS(DEVIATES) - NFREE
;         Note that this doesn't account for pegged parameters (see
;         NPEGGED).  It also does not account for data points which
;         are assigned zero weight by the user function.
;
;   ERRMSG - a string error or warning message is returned.
;
;   EXTERNAL_FVEC - upon input, the function values, evaluated at
;                   START_PARAMS.  This should be an M-vector, where M
;                   is the number of data points.
;
;   EXTERNAL_FJAC - upon input, the Jacobian array of partial
;                   derivative values.  This should be a M x N array,
;                   where M is the number of data points and N is the
;                   number of parameters.  NOTE: that all FIXED or
;                   TIED parameters must *not* be included in this
;                   array.
;
;   EXTERNAL_STATE - a named variable to store MPFIT-related state
;                    information between iterations (used in input and
;                    output to MPFIT).  The user must not manipulate
;                    or discard this data until the final iteration is
;                    performed.
;
;   FASTNORM - set this keyword to select a faster algorithm to
;              compute sum-of-square values internally.  For systems
;              with large numbers of data points, the standard
;              algorithm can become prohibitively slow because it
;              cannot be vectorized well.  By setting this keyword,
;              MPFIT will run faster, but it will be more prone to
;              floating point overflows and underflows.  Thus, setting
;              this keyword may sacrifice some stability in the
;              fitting process.
;              
;   FTOL - a nonnegative input variable. Termination occurs when both
;          the actual and predicted relative reductions in the sum of
;          squares are at most FTOL (and STATUS is accordingly set to
;          1 or 3).  Therefore, FTOL measures the relative error
;          desired in the sum of squares.  Default: 1D-10
;
;   FUNCTARGS - A structure which contains the parameters to be passed
;               to the user-supplied function specified by MYFUNCT via
;               the _EXTRA mechanism.  This is the way you can pass
;               additional data to your user-supplied function without
;               using common blocks.
;
;               Consider the following example:
;                if FUNCTARGS = { XVAL:[1.D,2,3], YVAL:[1.D,4,9],
;                                 ERRVAL:[1.D,1,1] }
;                then the user supplied function should be declared
;                like this:
;                FUNCTION MYFUNCT, P, XVAL=x, YVAL=y, ERRVAL=err
;
;               By default, no extra parameters are passed to the
;               user-supplied function, but your function should
;               accept *at least* one keyword parameter.  [ This is to
;               accomodate a limitation in IDL's _EXTRA
;               parameter-passing mechanism. ]
;
;   GTOL - a nonnegative input variable. Termination occurs when the
;          cosine of the angle between fvec and any column of the
;          jacobian is at most GTOL in absolute value (and STATUS is
;          accordingly set to 4). Therefore, GTOL measures the
;          orthogonality desired between the function vector and the
;          columns of the jacobian.  Default: 1D-10
;
;   ITERARGS - The keyword arguments to be passed to ITERPROC via the
;              _EXTRA mechanism.  This should be a structure, and is
;              similar in operation to FUNCTARGS.
;              Default: no arguments are passed.
;
;   ITERPRINT - The name of an IDL procedure, equivalent to PRINT,
;               that ITERPROC will use to render output.  ITERPRINT
;               should be able to accept at least four positional
;               arguments.  In addition, it should be able to accept
;               the standard FORMAT keyword for output formatting; and
;               the UNIT keyword, to redirect output to a logical file
;               unit (default should be UNIT=1, standard output).
;               These keywords are passed using the ITERARGS keyword
;               above.  The ITERPRINT procedure must accept the _EXTRA
;               keyword.  
;               NOTE: that much formatting can be handled with the 
;                     MPPRINT and MPFORMAT tags.
;               Default: 'MPFIT_DEFPRINT' (default internal formatter)
;
;   ITERPROC - The name of a procedure to be called upon each NPRINT
;              iteration of the MPFIT routine.  ITERPROC is always
;              called in the final iteration.  It should be declared
;              in the following way:
;
;              PRO ITERPROC, MYFUNCT, p, iter, fnorm, FUNCTARGS=fcnargs, $
;                PARINFO=parinfo, QUIET=quiet, DOF=dof, PFORMAT=pformat, $
;                UNIT=unit, ...
;                ; perform custom iteration update
;              END
;         
;              ITERPROC must either accept all three keyword
;              parameters (FUNCTARGS, PARINFO and QUIET), or at least
;              accept them via the _EXTRA keyword.
;          
;              MYFUNCT is the user-supplied function to be minimized,
;              P is the current set of model parameters, ITER is the
;              iteration number, and FUNCTARGS are the arguments to be
;              passed to MYFUNCT.  FNORM should be the chi-squared
;              value.  QUIET is set when no textual output should be
;              printed.  DOF is the number of degrees of freedom,
;              normally the number of points less the number of free
;              parameters.  See below for documentation of PARINFO.
;              PFORMAT is the default parameter value format.  UNIT is
;              passed on to the ITERPRINT procedure, and should
;              indicate the file unit where log output will be sent
;              (default: standard output).
;
;              In implementation, ITERPROC can perform updates to the
;              terminal or graphical user interface, to provide
;              feedback while the fit proceeds.  If the fit is to be
;              stopped for any reason, then ITERPROC should set the
;              common block variable ERROR_CODE to negative value
;              between -15 and -1 (see MPFIT_ERROR common block
;              below).  In principle, ITERPROC should probably not
;              modify the parameter values, because it may interfere
;              with the algorithm's stability.  In practice it is
;              allowed.
;
;              Default: an internal routine is used to print the
;                       parameter values.
;
;   ITERSTOP - Set this keyword if you wish to be able to stop the
;              fitting by hitting the predefined ITERKEYSTOP key on
;              the keyboard.  This only works if you use the default
;              ITERPROC.
;
;   ITERKEYSTOP - A keyboard key which will halt the fit (and if
;                 ITERSTOP is set and the default ITERPROC is used).
;                 ITERSTOPKEY may either be a one-character string
;                 with the desired key, or a scalar integer giving the
;                 ASCII code of the desired key.  
;                 Default: 7b (control-g)
;
;                 NOTE: the default value of ASCI 7 (control-G) cannot
;                 be read in some windowing environments, so you must
;                 change to a printable character like 'q'.
;
;   MAXITER - The maximum number of iterations to perform.  If the
;             number of calculation iterations exceeds MAXITER, then
;             the STATUS value is set to 5 and MPFIT returns.  
;
;             If MAXITER EQ 0, then MPFIT does not iterate to adjust
;             parameter values; however, the user function is evaluated
;             and parameter errors/covariance/Jacobian are estimated
;             before returning.
;             Default: 200 iterations
;
;   MIN_VERSION - The minimum requested version number.  This must be
;                 a scalar string of the form returned by the VERSION
;                 keyword.  If the current version of MPFIT does not
;                 satisfy the minimum requested version number, then,
;                    MPFIT(/query, min_version='...') returns 0
;                    MPFIT(...) returns NAN
;                 Default: no version number check
;                 NOTE: MIN_VERSION was added in MPFIT version 1.70
;
;   NFEV - the number of MYFUNCT function evaluations performed.
;
;   NFREE - the number of free parameters in the fit.  This includes
;           parameters which are not FIXED and not TIED, but it does
;           include parameters which are pegged at LIMITS.
;
;   NITER - the number of iterations completed.
;
;   NOCATCH - if set, then MPFIT will not perform any error trapping.
;             By default (not set), MPFIT will trap errors and report
;             them to the caller.  This keyword will typically be used
;             for debugging.
;
;   NOCOVAR - set this keyword to prevent the calculation of the
;             covariance matrix before returning (see COVAR)
;
;   NPEGGED - the number of free parameters which are pegged at a
;             LIMIT.
;
;   NPRINT - The frequency with which ITERPROC is called.  A value of
;            1 indicates that ITERPROC is called with every iteration,
;            while 2 indicates every other iteration, etc.  Be aware
;            that several Levenberg-Marquardt attempts can be made in
;            a single iteration.  Also, the ITERPROC is *always*
;            called for the final iteration, regardless of the
;            iteration number.
;            Default value: 1
;
;   PARINFO - A one-dimensional array of structures.
;             Provides a mechanism for more sophisticated constraints
;             to be placed on parameter values.  When PARINFO is not
;             passed, then it is assumed that all parameters are free
;             and unconstrained.  Values in PARINFO are never 
;             modified during a call to MPFIT.
;
;             See description above for the structure of PARINFO.
;
;             Default value:  all parameters are free and unconstrained.
;
;   PERROR - The formal 1-sigma errors in each parameter, computed
;            from the covariance matrix.  If a parameter is held
;            fixed, or if it touches a boundary, then the error is
;            reported as zero.
;
;            If the fit is unweighted (i.e. no errors were given, or
;            the weights were uniformly set to unity), then PERROR
;            will probably not represent the true parameter
;            uncertainties.  
;
;            *If* you can assume that the true reduced chi-squared
;            value is unity -- meaning that the fit is implicitly
;            assumed to be of good quality -- then the estimated
;            parameter uncertainties can be computed by scaling PERROR
;            by the measured chi-squared value.
;
;              DOF     = N_ELEMENTS(X) - N_ELEMENTS(PARMS) ; deg of freedom
;              PCERROR = PERROR * SQRT(BESTNORM / DOF)   ; scaled uncertainties
;
;   PFREE_INDEX - upon return, PFREE_INDEX contains an index array
;                 which indicates which parameter were allowed to
;                 vary.  I.e. of all the parameters PARMS, only
;                 PARMS[PFREE_INDEX] were varied.
;
;   QUERY - if set, then MPFIT() will return immediately with one of
;           the following values:
;                 1 - if MIN_VERSION is not set
;                 1 - if MIN_VERSION is set and MPFIT satisfies the minimum
;                 0 - if MIN_VERSION is set and MPFIT does not satisfy it
;           The VERSION output keyword is always set upon return.
;           Default: not set.
;
;   QUIET - set this keyword when no textual output should be printed
;           by MPFIT
;
;   RESDAMP - a scalar number, indicating the cut-off value of
;             residuals where "damping" will occur.  Residuals with
;             magnitudes greater than this number will be replaced by
;             their logarithm.  This partially mitigates the so-called
;             large residual problem inherent in least-squares solvers
;             (as for the test problem CURVI, http://www.maxthis.com/-
;             curviex.htm).  A value of 0 indicates no damping.
;             Default: 0
;
;             Note: RESDAMP doesn't work with AUTODERIV=0
;
;   STATUS - an integer status code is returned.  All values greater
;            than zero can represent success (however STATUS EQ 5 may
;            indicate failure to converge).  It can have one of the
;            following values:
;
;        -18  a fatal execution error has occurred.  More information
;             may be available in the ERRMSG string.
;
;        -16  a parameter or function value has become infinite or an
;             undefined number.  This is usually a consequence of
;             numerical overflow in the user's model function, which
;             must be avoided.
;
;        -15 to -1 
;             these are error codes that either MYFUNCT or ITERPROC
;             may return to terminate the fitting process (see
;             description of MPFIT_ERROR common below).  If either
;             MYFUNCT or ITERPROC set ERROR_CODE to a negative number,
;             then that number is returned in STATUS.  Values from -15
;             to -1 are reserved for the user functions and will not
;             clash with MPFIT.
;
;	   0  improper input parameters.
;         
;	   1  both actual and predicted relative reductions
;	      in the sum of squares are at most FTOL.
;         
;	   2  relative error between two consecutive iterates
;	      is at most XTOL
;         
;	   3  conditions for STATUS = 1 and STATUS = 2 both hold.
;         
;	   4  the cosine of the angle between fvec and any
;	      column of the jacobian is at most GTOL in
;	      absolute value.
;         
;	   5  the maximum number of iterations has been reached
;         
;	   6  FTOL is too small. no further reduction in
;	      the sum of squares is possible.
;         
;	   7  XTOL is too small. no further improvement in
;	      the approximate solution x is possible.
;         
;	   8  GTOL is too small. fvec is orthogonal to the
;	      columns of the jacobian to machine precision.
;
;          9  A successful single iteration has been completed, and
;             the user must supply another "EXTERNAL" evaluation of
;             the function and its derivatives.  This status indicator
;             is neither an error nor a convergence indicator.
;
;   VERSION - upon return, VERSION will be set to the MPFIT internal
;             version number.  The version number will be a string of
;             the form "X.Y" where X is a major revision number and Y
;             is a minor revision number.
;             NOTE: the VERSION keyword was not present before 
;               MPFIT version number 1.70, therefore, callers must 
;               use exception handling when using this keyword.
;
;   XTOL - a nonnegative input variable. Termination occurs when the
;          relative error between two consecutive iterates is at most
;          XTOL (and STATUS is accordingly set to 2 or 3).  Therefore,
;          XTOL measures the relative error desired in the approximate
;          solution.  Default: 1D-10
;
;
; EXAMPLE:
;
;   p0 = [5.7D, 2.2, 500., 1.5, 2000.]
;   fa = {X:x, Y:y, ERR:err}
;   p = mpfit('MYFUNCT', p0, functargs=fa)
;
;   Minimizes sum of squares of MYFUNCT.  MYFUNCT is called with the X,
;   Y, and ERR keyword parameters that are given by FUNCTARGS.  The
;   resulting parameter values are returned in p.
;
;
; COMMON BLOCKS:
;
;   COMMON MPFIT_ERROR, ERROR_CODE
;
;     User routines may stop the fitting process at any time by
;     setting an error condition.  This condition may be set in either
;     the user's model computation routine (MYFUNCT), or in the
;     iteration procedure (ITERPROC).
;
;     To stop the fitting, the above common block must be declared,
;     and ERROR_CODE must be set to a negative number.  After the user
;     procedure or function returns, MPFIT checks the value of this
;     common block variable and exits immediately if the error
;     condition has been set.  This value is also returned in the
;     STATUS keyword: values of -1 through -15 are reserved error
;     codes for the user routines.  By default the value of ERROR_CODE
;     is zero, indicating a successful function/procedure call.
;
;   COMMON MPFIT_PROFILE
;   COMMON MPFIT_MACHAR
;   COMMON MPFIT_CONFIG
;
;     These are undocumented common blocks are used internally by
;     MPFIT and may change in future implementations.
;
; THEORY OF OPERATION:
;
;   There are many specific strategies for function minimization.  One
;   very popular technique is to use function gradient information to
;   realize the local structure of the function.  Near a local minimum
;   the function value can be taylor expanded about x0 as follows:
;
;      f(x) = f(x0) + f'(x0) . (x-x0) + (1/2) (x-x0) . f''(x0) . (x-x0)
;             -----   ---------------   -------------------------------  (1)
;     Order    0th          1st                      2nd
;
;   Here f'(x) is the gradient vector of f at x, and f''(x) is the
;   Hessian matrix of second derivatives of f at x.  The vector x is
;   the set of function parameters, not the measured data vector.  One
;   can find the minimum of f, f(xm) using Newton's method, and
;   arrives at the following linear equation:
;
;      f''(x0) . (xm-x0) = - f'(x0)                            (2)
;
;   If an inverse can be found for f''(x0) then one can solve for
;   (xm-x0), the step vector from the current position x0 to the new
;   projected minimum.  Here the problem has been linearized (ie, the
;   gradient information is known to first order).  f''(x0) is
;   symmetric n x n matrix, and should be positive definite.
;
;   The Levenberg - Marquardt technique is a variation on this theme.
;   It adds an additional diagonal term to the equation which may aid the
;   convergence properties:
;
;      (f''(x0) + nu I) . (xm-x0) = -f'(x0)                  (2a)
;
;   where I is the identity matrix.  When nu is large, the overall
;   matrix is diagonally dominant, and the iterations follow steepest
;   descent.  When nu is small, the iterations are quadratically
;   convergent.
;
;   In principle, if f''(x0) and f'(x0) are known then xm-x0 can be
;   determined.  However the Hessian matrix is often difficult or
;   impossible to compute.  The gradient f'(x0) may be easier to
;   compute, if even by finite difference techniques.  So-called
;   quasi-Newton techniques attempt to successively estimate f''(x0)
;   by building up gradient information as the iterations proceed.
;
;   In the least squares problem there are further simplifications
;   which assist in solving eqn (2).  The function to be minimized is
;   a sum of squares:
;
;       f = Sum(hi^2)                                         (3)
;
;   where hi is the ith residual out of m residuals as described
;   above.  This can be substituted back into eqn (2) after computing
;   the derivatives:
;
;       f'  = 2 Sum(hi  hi')     
;       f'' = 2 Sum(hi' hj') + 2 Sum(hi hi'')                (4)
;
;   If one assumes that the parameters are already close enough to a
;   minimum, then one typically finds that the second term in f'' is
;   negligible [or, in any case, is too difficult to compute].  Thus,
;   equation (2) can be solved, at least approximately, using only
;   gradient information.
;
;   In matrix notation, the combination of eqns (2) and (4) becomes:
;
;        hT' . h' . dx = - hT' . h                          (5)
;
;   Where h is the residual vector (length m), hT is its transpose, h'
;   is the Jacobian matrix (dimensions n x m), and dx is (xm-x0).  The
;   user function supplies the residual vector h, and in some cases h'
;   when it is not found by finite differences (see MPFIT_FDJAC2,
;   which finds h and hT').  Even if dx is not the best absolute step
;   to take, it does provide a good estimate of the best *direction*,
;   so often a line minimization will occur along the dx vector
;   direction.
;
;   The method of solution employed by MINPACK is to form the Q . R
;   factorization of h', where Q is an orthogonal matrix such that QT .
;   Q = I, and R is upper right triangular.  Using h' = Q . R and the
;   ortogonality of Q, eqn (5) becomes
;
;        (RT . QT) . (Q . R) . dx = - (RT . QT) . h
;                     RT . R . dx = - RT . QT . h         (6)
;                          R . dx = - QT . h
;
;   where the last statement follows because R is upper triangular.
;   Here, R, QT and h are known so this is a matter of solving for dx.
;   The routine MPFIT_QRFAC provides the QR factorization of h, with
;   pivoting, and MPFIT_QRSOL;V provides the solution for dx.
;   
; REFERENCES:
;
;   Markwardt, C. B. 2008, "Non-Linear Least Squares Fitting in IDL
;     with MPFIT," in proc. Astronomical Data Analysis Software and
;     Systems XVIII, Quebec, Canada, ASP Conference Series, Vol. XXX, eds.
;     D. Bohlender, P. Dowler & D. Durand (Astronomical Society of the
;     Pacific: San Francisco), p. 251-254 (ISBN: 978-1-58381-702-5)
;       http://arxiv.org/abs/0902.2850
;       Link to NASA ADS: http://adsabs.harvard.edu/abs/2009ASPC..411..251M
;       Link to ASP: http://aspbooks.org/a/volumes/table_of_contents/411
;
;   Refer to the MPFIT website as:
;       http://purl.com/net/mpfit
;
;   MINPACK-1 software, by Jorge More' et al, available from netlib.
;     http://www.netlib.org/
;
;   "Optimization Software Guide," Jorge More' and Stephen Wright, 
;     SIAM, *Frontiers in Applied Mathematics*, Number 14.
;     (ISBN: 978-0-898713-22-0)
;
;   More', J. 1978, "The Levenberg-Marquardt Algorithm: Implementation
;     and Theory," in Numerical Analysis, vol. 630, ed. G. A. Watson
;     (Springer-Verlag: Berlin), p. 105 (DOI: 10.1007/BFb0067690 )
;
; MODIFICATION HISTORY:
;   Translated from MINPACK-1 in FORTRAN, Apr-Jul 1998, CM
;   Fixed bug in parameter limits (x vs xnew), 04 Aug 1998, CM
;   Added PERROR keyword, 04 Aug 1998, CM
;   Added COVAR keyword, 20 Aug 1998, CM
;   Added NITER output keyword, 05 Oct 1998
;      D.L Windt, Bell Labs, windt@bell-labs.com;
;   Made each PARINFO component optional, 05 Oct 1998 CM
;   Analytical derivatives allowed via AUTODERIVATIVE keyword, 09 Nov 1998
;   Parameter values can be tied to others, 09 Nov 1998
;   Fixed small bugs (Wayne Landsman), 24 Nov 1998
;   Added better exception error reporting, 24 Nov 1998 CM
;   Cosmetic documentation changes, 02 Jan 1999 CM
;   Changed definition of ITERPROC to be consistent with TNMIN, 19 Jan 1999 CM
;   Fixed bug when AUTDERIVATIVE=0.  Incorrect sign, 02 Feb 1999 CM
;   Added keyboard stop to MPFIT_DEFITER, 28 Feb 1999 CM
;   Cosmetic documentation changes, 14 May 1999 CM
;   IDL optimizations for speed & FASTNORM keyword, 15 May 1999 CM
;   Tried a faster version of mpfit_enorm, 30 May 1999 CM
;   Changed web address to cow.physics.wisc.edu, 14 Jun 1999 CM
;   Found malformation of FDJAC in MPFIT for 1 parm, 03 Aug 1999 CM
;   Factored out user-function call into MPFIT_CALL.  It is possible,
;     but currently disabled, to call procedures.  The calling format
;     is similar to CURVEFIT, 25 Sep 1999, CM
;   Slightly changed mpfit_tie to be less intrusive, 25 Sep 1999, CM
;   Fixed some bugs associated with tied parameters in mpfit_fdjac, 25
;     Sep 1999, CM
;   Reordered documentation; now alphabetical, 02 Oct 1999, CM
;   Added QUERY keyword for more robust error detection in drivers, 29
;     Oct 1999, CM
;   Documented PERROR for unweighted fits, 03 Nov 1999, CM
;   Split out MPFIT_RESETPROF to aid in profiling, 03 Nov 1999, CM
;   Some profiling and speed optimization, 03 Nov 1999, CM
;     Worst offenders, in order: fdjac2, qrfac, qrsolv, enorm.
;     fdjac2 depends on user function, qrfac and enorm seem to be
;     fully optimized.  qrsolv probably could be tweaked a little, but
;     is still <10% of total compute time.
;   Made sure that !err was set to 0 in MPFIT_DEFITER, 10 Jan 2000, CM
;   Fixed small inconsistency in setting of QANYLIM, 28 Jan 2000, CM
;   Added PARINFO field RELSTEP, 28 Jan 2000, CM
;   Converted to MPFIT_ERROR common block for indicating error
;     conditions, 28 Jan 2000, CM
;   Corrected scope of MPFIT_ERROR common block, CM, 07 Mar 2000
;   Minor speed improvement in MPFIT_ENORM, CM 26 Mar 2000
;   Corrected case where ITERPROC changed parameter values and
;     parameter values were TIED, CM 26 Mar 2000
;   Changed MPFIT_CALL to modify NFEV automatically, and to support
;     user procedures more, CM 26 Mar 2000
;   Copying permission terms have been liberalized, 26 Mar 2000, CM
;   Catch zero value of zero a(j,lj) in MPFIT_QRFAC, 20 Jul 2000, CM
;      (thanks to David Schlegel <schlegel@astro.princeton.edu>)
;   MPFIT_SETMACHAR is called only once at init; only one common block
;     is created (MPFIT_MACHAR); it is now a structure; removed almost
;     all CHECK_MATH calls for compatibility with IDL5 and !EXCEPT;
;     profiling data is now in a structure too; noted some
;     mathematical discrepancies in Linux IDL5.0, 17 Nov 2000, CM
;   Some significant changes.  New PARINFO fields: MPSIDE, MPMINSTEP,
;     MPMAXSTEP.  Improved documentation.  Now PTIED constraints are
;     maintained in the MPCONFIG common block.  A new procedure to
;     parse PARINFO fields.  FDJAC2 now computes a larger variety of
;     one-sided and two-sided finite difference derivatives.  NFEV is
;     stored in the MPCONFIG common now.  17 Dec 2000, CM
;   Added check that PARINFO and XALL have same size, 29 Dec 2000 CM
;   Don't call function in TERMINATE when there is an error, 05 Jan
;     2000
;   Check for float vs. double discrepancies; corrected implementation
;     of MIN/MAXSTEP, which I still am not sure of, but now at least
;     the correct behavior occurs *without* it, CM 08 Jan 2001
;   Added SCALE_FCN keyword, to allow for scaling, as for the CASH
;     statistic; added documentation about the theory of operation,
;     and under the QR factorization; slowly I'm beginning to
;     understand the bowels of this algorithm, CM 10 Jan 2001
;   Remove MPMINSTEP field of PARINFO, for now at least, CM 11 Jan
;     2001
;   Added RESDAMP keyword, CM, 14 Jan 2001
;   Tried to improve the DAMP handling a little, CM, 13 Mar 2001
;   Corrected .PARNAME behavior in _DEFITER, CM, 19 Mar 2001
;   Added checks for parameter and function overflow; a new STATUS
;     value to reflect this; STATUS values of -15 to -1 are reserved
;     for user function errors, CM, 03 Apr 2001
;   DAMP keyword is now a TANH, CM, 03 Apr 2001
;   Added more error checking of float vs. double, CM, 07 Apr 2001
;   Fixed bug in handling of parameter lower limits; moved overflow
;     checking to end of loop, CM, 20 Apr 2001
;   Failure using GOTO, TERMINATE more graceful if FNORM1 not defined,
;     CM, 13 Aug 2001
;   Add MPPRINT tag to PARINFO, CM, 19 Nov 2001
;   Add DOF keyword to DEFITER procedure, and print degrees of
;     freedom, CM, 28 Nov 2001
;   Add check to be sure MYFUNCT is a scalar string, CM, 14 Jan 2002
;   Addition of EXTERNAL_FJAC, EXTERNAL_FVEC keywords; ability to save
;     fitter's state from one call to the next; allow '(EXTERNAL)'
;     function name, which implies that user will supply function and
;     Jacobian at each iteration, CM, 10 Mar 2002
;   Documented EXTERNAL evaluation code, CM, 10 Mar 2002
;   Corrected signficant bug in the way that the STEP parameter, and
;     FIXED parameters interacted (Thanks Andrew Steffl), CM, 02 Apr
;     2002
;   Allow COVAR and PERROR keywords to be computed, even in case of
;     '(EXTERNAL)' function, 26 May 2002
;   Add NFREE and NPEGGED keywords; compute NPEGGED; compute DOF using
;     NFREE instead of n_elements(X), thanks to Kristian Kjaer, CM 11
;     Sep 2002
;   Hopefully PERROR is all positive now, CM 13 Sep 2002
;   Documented RELSTEP field of PARINFO (!!), CM, 25 Oct 2002
;   Error checking to detect missing start pars, CM 12 Apr 2003
;   Add DOF keyword to return degrees of freedom, CM, 30 June 2003
;   Always call ITERPROC in the final iteration; add ITERKEYSTOP
;     keyword, CM, 30 June 2003
;   Correct bug in MPFIT_LMPAR of singularity handling, which might
;     likely be fatal for one-parameter fits, CM, 21 Nov 2003
;     (with thanks to Peter Tuthill for the proper test case)
;   Minor documentation adjustment, 03 Feb 2004, CM
;   Correct small error in QR factorization when pivoting; document
;     the return values of QRFAC when pivoting, 21 May 2004, CM
;   Add MPFORMAT field to PARINFO, and correct behavior of interaction
;     between MPPRINT and PARNAME in MPFIT_DEFITERPROC (thanks to Tim
;     Robishaw), 23 May 2004, CM
;   Add the ITERPRINT keyword to allow redirecting output, 26 Sep
;     2004, CM
;   Correct MAXSTEP behavior in case of a negative parameter, 26 Sep
;     2004, CM
;   Fix bug in the parsing of MINSTEP/MAXSTEP, 10 Apr 2005, CM
;   Fix bug in the handling of upper/lower limits when the limit was
;     negative (the fitting code would never "stick" to the lower
;     limit), 29 Jun 2005, CM
;   Small documentation update for the TIED field, 05 Sep 2005, CM
;   Convert to IDL 5 array syntax (!), 16 Jul 2006, CM
;   If MAXITER equals zero, then do the basic parameter checking and
;     uncertainty analysis, but do not adjust the parameters, 15 Aug
;     2006, CM
;   Added documentation, 18 Sep 2006, CM
;   A few more IDL 5 array syntax changes, 25 Sep 2006, CM
;   Move STRICTARR compile option inside each function/procedure, 9 Oct 2006
;   Bug fix for case of MPMAXSTEP and fixed parameters, thanks
;     to Huib Intema (who found it from the Python translation!), 05 Feb 2007
;   Similar fix for MPFIT_FDJAC2 and the MPSIDE sidedness of
;     derivatives, also thanks to Huib Intema, 07 Feb 2007
;   Clarify documentation on user-function, derivatives, and PARINFO,
;     27 May 2007
;   Change the wording of "Analytic Derivatives" to "Explicit 
;     Derivatives" in the documentation, CM, 03 Sep 2007
;   Further documentation tweaks, CM, 13 Dec 2007
;   Add COMPATIBILITY section and add credits to copyright, CM, 13 Dec
;      2007
;   Document and enforce that START_PARMS and PARINFO are 1-d arrays,
;      CM, 29 Mar 2008
;   Previous change for 1-D arrays wasn't correct for
;      PARINFO.LIMITED/.LIMITS; now fixed, CM, 03 May 2008
;   Documentation adjustments, CM, 20 Aug 2008
;   Change some minor FOR-loop variables to type-long, CM, 03 Sep 2008
;   Change error handling slightly, document NOCATCH keyword,
;      document error handling in general, CM, 01 Oct 2008
;   Special case: when either LIMITS is zero, and a parameter pushes
;      against that limit, the coded that 'pegged' it there would not
;      work since it was a relative condition; now zero is handled
;      properly, CM, 08 Nov 2008
;   Documentation of how TIED interacts with LIMITS, CM, 21 Dec 2008
;   Better documentation of references, CM, 27 Feb 2009
;   If MAXITER=0, then be sure to set STATUS=5, which permits the
;      the covariance matrix to be computed, CM, 14 Apr 2009
;   Avoid numerical underflow while solving for the LM parameter,
;      (thanks to Sergey Koposov) CM, 14 Apr 2009
;   Use individual functions for all possible MPFIT_CALL permutations,
;      (and make sure the syntax is right) CM, 01 Sep 2009
;   Correct behavior of MPMAXSTEP when some parameters are frozen,
;      thanks to Josh Destree, CM, 22 Nov 2009
;   Update the references section, CM, 22 Nov 2009
;   1.70 - Add the VERSION and MIN_VERSION keywords, CM, 22 Nov 2009
;   1.71 - Store pre-calculated revision in common, CM, 23 Nov 2009
;   1.72-1.74 - Documented alternate method to compute correlation matrix,
;          CM, 05 Feb 2010
;   1.75 - Enforce TIED constraints when preparing to terminate the
;          routine, CM, 2010-06-22
;   1.76 - Documented input keywords now are not modified upon output,
;          CM, 2010-07-13
;   1.77 - Upon user request (/CALC_FJAC), compute Jacobian matrix and
;          return in BEST_FJAC; also return best residuals in
;          BEST_RESID; also return an index list of free parameters as
;          PFREE_INDEX; add a fencepost to prevent recursion
;          CM, 2010-10-27
;   1.79 - Documentation corrections.  CM, 2011-08-26
;   1.81 - Fix bug in interaction of AUTODERIVATIVE=0 and .MPSIDE=3;
;          Document FJAC_MASK. CM, 2012-05-08
;
;  $Id: mpfit.pro,v 1.82 2012/09/27 23:59:44 cmarkwar Exp $
;-
; Original MINPACK by More' Garbow and Hillstrom, translated with permission
; Modifications and enhancements are:
; Copyright (C) 1997-2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
;; Reset profiling registers for another run.  By default, and when
;; uncommented, the profiling registers simply accumulate.

pro mpfit_resetprof
  COMPILE_OPT strictarr
  common mpfit_profile, mpfit_profile_vals

  mpfit_profile_vals = { status: 1L, fdjac2: 0D, lmpar: 0D, mpfit: 0D, $
                         qrfac: 0D,  qrsolv: 0D, enorm: 0D}
  return
end

;; Following are machine constants that can be loaded once.  I have
;; found that bizarre underflow messages can be produced in each call
;; to MACHAR(), so this structure minimizes the number of calls to
;; one.

pro mpfit_setmachar, double=isdouble
  COMPILE_OPT strictarr
  common mpfit_profile, profvals
  if n_elements(profvals) EQ 0 then mpfit_resetprof

  common mpfit_machar, mpfit_machar_vals

  ;; In earlier versions of IDL, MACHAR itself could produce a load of
  ;; error messages.  We try to mask some of that out here.
  if (!version.release) LT 5 then dummy = check_math(1, 1)

  mch = 0.
  mch = machar(double=keyword_set(isdouble))
  dmachep = mch.eps
  dmaxnum = mch.xmax
  dminnum = mch.xmin
  dmaxlog = alog(mch.xmax)
  dminlog = alog(mch.xmin)
  if keyword_set(isdouble) then $
    dmaxgam = 171.624376956302725D $
  else $
    dmaxgam = 171.624376956302725
  drdwarf = sqrt(dminnum*1.5) * 10
  drgiant = sqrt(dmaxnum) * 0.1

  mpfit_machar_vals = {machep: dmachep, maxnum: dmaxnum, minnum: dminnum, $
                       maxlog: dmaxlog, minlog: dminlog, maxgam: dmaxgam, $
                       rdwarf: drdwarf, rgiant: drgiant}

  if (!version.release) LT 5 then dummy = check_math(0, 0)

  return
end


; Call user function with no _EXTRA parameters
function mpfit_call_func_noextra, fcn, x, fjac, _EXTRA=extra
  if n_params() EQ 2 then begin
     return, call_function(fcn, x)
  endif else begin
     return, call_function(fcn, x, fjac)
  endelse
end

; Call user function with _EXTRA parameters
function mpfit_call_func_extra, fcn, x, fjac, _EXTRA=extra
  if n_params() EQ 2 then begin
     return, call_function(fcn, x, _EXTRA=extra)
  endif else begin
     return, call_function(fcn, x, fjac, _EXTRA=extra)
  endelse
end

; Call user procedure with no _EXTRA parameters
function mpfit_call_pro_noextra, fcn, x, fjac, _EXTRA=extra
  if n_params() EQ 2 then begin
     call_procedure, fcn, x, f
  endif else begin
     call_procedure, fcn, x, f, fjac
  endelse
  return, f
end

; Call user procedure with _EXTRA parameters
function mpfit_call_pro_extra, fcn, x, fjac, _EXTRA=extra
  if n_params() EQ 2 then begin
     call_procedure, fcn, x, f, _EXTRA=extra
  endif else begin
     call_procedure, fcn, x, f, fjac, _EXTRA=extra
  endelse
  return, f
end


;; Call user function or procedure, with _EXTRA or not, with
;; derivatives or not.
function mpfit_call, fcn, x, fjac, _EXTRA=extra

  COMPILE_OPT strictarr
  common mpfit_config, mpconfig

  if keyword_set(mpconfig.qanytied) then mpfit_tie, x, mpconfig.ptied

  ;; Decide whether we are calling a procedure or function, and 
  ;; with/without FUNCTARGS
  proname = 'MPFIT_CALL'
  proname = proname + ((mpconfig.proc) ? '_PRO' : '_FUNC')
  proname = proname + ((n_elements(extra) GT 0) ? '_EXTRA' : '_NOEXTRA')

  if n_params() EQ 2 then begin
     f = call_function(proname, fcn, x, _EXTRA=extra)
  endif else begin
     f = call_function(proname, fcn, x, fjac, _EXTRA=extra)
  endelse
  mpconfig.nfev = mpconfig.nfev + 1

  if n_params() EQ 2 AND mpconfig.damp GT 0 then begin
      damp = mpconfig.damp[0]
      
      ;; Apply the damping if requested.  This replaces the residuals
      ;; with their hyperbolic tangent.  Thus residuals larger than
      ;; DAMP are essentially clipped.
      f = tanh(f/damp)
  endif

  return, f
end

function mpfit_fdjac2, fcn, x, fvec, step, ulimited, ulimit, dside, $
                 iflag=iflag, epsfcn=epsfcn, autoderiv=autoderiv, $
                 FUNCTARGS=fcnargs, xall=xall, ifree=ifree, dstep=dstep, $
                 deriv_debug=ddebug, deriv_reltol=ddrtol, deriv_abstol=ddatol

  COMPILE_OPT strictarr
  common mpfit_machar, machvals
  common mpfit_profile, profvals
  common mpfit_error, mperr

;  prof_start = systime(1)
  MACHEP0 = machvals.machep
  DWARF   = machvals.minnum

  if n_elements(epsfcn) EQ 0 then epsfcn = MACHEP0
  if n_elements(xall)   EQ 0 then xall = x
  if n_elements(ifree)  EQ 0 then ifree = lindgen(n_elements(xall))
  if n_elements(step)   EQ 0 then step = x * 0.
  if n_elements(ddebug) EQ 0 then ddebug = intarr(n_elements(xall))
  if n_elements(ddrtol) EQ 0 then ddrtol = x * 0.
  if n_elements(ddatol) EQ 0 then ddatol = x * 0.
  has_debug_deriv = max(ddebug)

  if keyword_set(has_debug_deriv) then begin
      ;; Header for debugging
      print, 'FJAC DEBUG BEGIN'
      print, "IPNT", "FUNC", "DERIV_U", "DERIV_N", "DIFF_ABS", "DIFF_REL", $
        format='("#  ",A10," ",A10," ",A10," ",A10," ",A10," ",A10)'
  endif

  nall = n_elements(xall)

  eps = sqrt(max([epsfcn, MACHEP0]));
  m = n_elements(fvec)
  n = n_elements(x)

  ;; Compute analytical derivative if requested
  ;; Two ways to enable computation of explicit derivatives:
  ;;   1. AUTODERIVATIVE=0
  ;;   2. AUTODERIVATIVE=1, but P[i].MPSIDE EQ 3

  if keyword_set(autoderiv) EQ 0 OR max(dside[ifree] EQ 3) EQ 1 then begin
      fjac_mask = intarr(nall)
      ;; Specify which parameters need derivatives
      ;;                  ---- Case 2 ------     ----- Case 1 -----
      fjac_mask[ifree] = (dside[ifree] EQ 3) OR (keyword_set(autoderiv) EQ 0)
      if has_debug_deriv then $
        print, fjac_mask, format='("# FJAC_MASK = ",100000(I0," ",:))'

      fjac = fjac_mask  ;; Pass the mask to the calling function as FJAC
      mperr = 0
      fp = mpfit_call(fcn, xall, fjac, _EXTRA=fcnargs)
      iflag = mperr

      if n_elements(fjac) NE m*nall then begin
          message, /cont, 'ERROR: Derivative matrix was not computed properly.'
          iflag = 1
;          profvals.fdjac2 = profvals.fdjac2 + (systime(1) - prof_start)
          return, 0
      endif

      ;; This definition is consistent with CURVEFIT (WRONG, see below)
      ;; Sign error found (thanks Jesus Fernandez <fernande@irm.chu-caen.fr>)

      ;; ... and now I regret doing this sign flip since it's not
      ;; strictly correct.  The definition should be RESID =
      ;; (Y-F)/SIGMA, so d(RESID)/dP should be -dF/dP.  My response to
      ;; Fernandez was unfounded because he was trying to supply
      ;; dF/dP.  Sigh. (CM 31 Aug 2007)

      fjac = reform(-temporary(fjac), m, nall, /overwrite)

      ;; Select only the free parameters
      if n_elements(ifree) LT nall then $
        fjac = reform(fjac[*,ifree], m, n, /overwrite)
      
      ;; Are we done computing derivatives?  The answer is, YES, if we
      ;; computed explicit derivatives for all free parameters, EXCEPT
      ;; when we are going on to compute debugging derivatives.
      if min(fjac_mask[ifree]) EQ 1 AND NOT has_debug_deriv then begin
          return, fjac
      endif
  endif

  ;; Final output array, if it was not already created above
  if n_elements(fjac) EQ 0 then begin
      fjac = make_array(m, n, value=fvec[0]*0.)
      fjac = reform(fjac, m, n, /overwrite)
  endif

  h = eps * abs(x)

  ;; if STEP is given, use that
  ;; STEP includes the fixed parameters
  if n_elements(step) GT 0 then begin
      stepi = step[ifree]
      wh = where(stepi GT 0, ct)
      if ct GT 0 then h[wh] = stepi[wh]
  endif

  ;; if relative step is given, use that
  ;; DSTEP includes the fixed parameters
  if n_elements(dstep) GT 0 then begin
      dstepi = dstep[ifree]
      wh = where(dstepi GT 0, ct)
      if ct GT 0 then h[wh] = abs(dstepi[wh]*x[wh])
  endif

  ;; In case any of the step values are zero
  wh = where(h EQ 0, ct)
  if ct GT 0 then h[wh] = eps

  ;; Reverse the sign of the step if we are up against the parameter
  ;; limit, or if the user requested it.
  ;; DSIDE includes the fixed parameters (ULIMITED/ULIMIT have only
  ;; varying ones)
  mask = dside[ifree] EQ -1
  if n_elements(ulimited) GT 0 AND n_elements(ulimit) GT 0 then $
    mask = mask OR (ulimited AND (x GT ulimit-h))
  wh = where(mask, ct)
  if ct GT 0 then h[wh] = -h[wh]

  ;; Loop through parameters, computing the derivative for each
  for j=0L, n-1 do begin
      dsidej = dside[ifree[j]]
      ddebugj = ddebug[ifree[j]]

      ;; Skip this parameter if we already computed its derivative
      ;; explicitly, and we are not debugging.
      if (dsidej EQ 3) AND (ddebugj EQ 0) then continue
      if (dsidej EQ 3) AND (ddebugj EQ 1) then $
        print, ifree[j], format='("FJAC PARM ",I0)'

      xp = xall
      xp[ifree[j]] = xp[ifree[j]] + h[j]
      
      mperr = 0
      fp = mpfit_call(fcn, xp, _EXTRA=fcnargs)
      
      iflag = mperr
      if iflag LT 0 then return, !values.d_nan

      if ((dsidej GE -1) AND (dsidej LE 1)) OR (dsidej EQ 3) then begin
          ;; COMPUTE THE ONE-SIDED DERIVATIVE
          ;; Note optimization fjac(0:*,j)
          fjacj = (fp-fvec)/h[j]

      endif else begin
          ;; COMPUTE THE TWO-SIDED DERIVATIVE
          xp[ifree[j]] = xall[ifree[j]] - h[j]

          mperr = 0
          fm = mpfit_call(fcn, xp, _EXTRA=fcnargs)
          
          iflag = mperr
          if iflag LT 0 then return, !values.d_nan
          
          ;; Note optimization fjac(0:*,j)
          fjacj = (fp-fm)/(2*h[j])
      endelse          
      
      ;; Debugging of explicit derivatives
      if (dsidej EQ 3) AND (ddebugj EQ 1) then begin
          ;; Relative and absolute tolerances
          dr = ddrtol[ifree[j]] & da = ddatol[ifree[j]]

          ;; Explicitly calculated
          fjaco = fjac[*,j]
          
          ;; If tolerances are zero, then any value for deriv triggers print...
          if (da EQ 0 AND dr EQ 0) then $
            diffj = (fjaco NE 0 OR fjacj NE 0)
          ;; ... otherwise the difference must be a greater than tolerance
          if (da NE 0 OR dr NE 0) then $
            diffj = (abs(fjaco-fjacj) GT (da+abs(fjaco)*dr))

          for k = 0L, m-1 do if diffj[k] then begin
              print, k, fvec[k], fjaco[k], fjacj[k], fjaco[k]-fjacj[k], $
                (fjaco[k] EQ 0)?(0):((fjaco[k]-fjacj[k])/fjaco[k]), $
                format='("   ",I10," ",G10.4," ",G10.4," ",G10.4," ",G10.4," ",G10.4)'
          endif
      endif

      ;; Store final results in output array
      fjac[0,j] = fjacj
          
  endfor

  if has_debug_deriv then print, 'FJAC DEBUG END'

;  profvals.fdjac2 = profvals.fdjac2 + (systime(1) - prof_start)
  return, fjac
end

function mpfit_enorm, vec

  COMPILE_OPT strictarr
  ;; NOTE: it turns out that, for systems that have a lot of data
  ;; points, this routine is a big computing bottleneck.  The extended
  ;; computations that need to be done cannot be effectively
  ;; vectorized.  The introduction of the FASTNORM configuration
  ;; parameter allows the user to select a faster routine, which is 
  ;; based on TOTAL() alone.
  common mpfit_profile, profvals
;  prof_start = systime(1)

  common mpfit_config, mpconfig
; Very simple-minded sum-of-squares
  if n_elements(mpconfig) GT 0 then if mpconfig.fastnorm then begin
      ans = sqrt(total(vec^2))
      goto, TERMINATE
  endif

  common mpfit_machar, machvals

  agiant = machvals.rgiant / n_elements(vec)
  adwarf = machvals.rdwarf * n_elements(vec)

  ;; This is hopefully a compromise between speed and robustness.
  ;; Need to do this because of the possibility of over- or underflow.
  mx = max(vec, min=mn)
  mx = max(abs([mx,mn]))
  if mx EQ 0 then return, vec[0]*0.

  if mx GT agiant OR mx LT adwarf then ans = mx * sqrt(total((vec/mx)^2))$
  else                                 ans = sqrt( total(vec^2) )

  TERMINATE:
;  profvals.enorm = profvals.enorm + (systime(1) - prof_start)
  return, ans
end

;     **********
;
;     subroutine qrfac
;
;     this subroutine uses householder transformations with column
;     pivoting (optional) to compute a qr factorization of the
;     m by n matrix a. that is, qrfac determines an orthogonal
;     matrix q, a permutation matrix p, and an upper trapezoidal
;     matrix r with diagonal elements of nonincreasing magnitude,
;     such that a*p = q*r. the householder transformation for
;     column k, k = 1,2,...,min(m,n), is of the form
;
;			    t
;	    i - (1/u(k))*u*u
;
;     where u has zeros in the first k-1 positions. the form of
;     this transformation and the method of pivoting first
;     appeared in the corresponding linpack subroutine.
;
;     the subroutine statement is
;
;	subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
;
;     where
;
;	m is a positive integer input variable set to the number
;	  of rows of a.
;
;	n is a positive integer input variable set to the number
;	  of columns of a.
;
;	a is an m by n array. on input a contains the matrix for
;	  which the qr factorization is to be computed. on output
;	  the strict upper trapezoidal part of a contains the strict
;	  upper trapezoidal part of r, and the lower trapezoidal
;	  part of a contains a factored form of q (the non-trivial
;	  elements of the u vectors described above).
;
;	lda is a positive integer input variable not less than m
;	  which specifies the leading dimension of the array a.
;
;	pivot is a logical input variable. if pivot is set true,
;	  then column pivoting is enforced. if pivot is set false,
;	  then no column pivoting is done.
;
;	ipvt is an integer output array of length lipvt. ipvt
;	  defines the permutation matrix p such that a*p = q*r.
;	  column j of p is column ipvt(j) of the identity matrix.
;	  if pivot is false, ipvt is not referenced.
;
;	lipvt is a positive integer input variable. if pivot is false,
;	  then lipvt may be as small as 1. if pivot is true, then
;	  lipvt must be at least n.
;
;	rdiag is an output array of length n which contains the
;	  diagonal elements of r.
;
;	acnorm is an output array of length n which contains the
;	  norms of the corresponding columns of the input matrix a.
;	  if this information is not needed, then acnorm can coincide
;	  with rdiag.
;
;	wa is a work array of length n. if pivot is false, then wa
;	  can coincide with rdiag.
;
;     subprograms called
;
;	minpack-supplied ... dpmpar,enorm
;
;	fortran-supplied ... dmax1,dsqrt,min0
;
;     argonne national laboratory. minpack project. march 1980.
;     burton s. garbow, kenneth e. hillstrom, jorge j. more
;
;     **********
;
; PIVOTING / PERMUTING:
;
; Upon return, A(*,*) is in standard parameter order, A(*,IPVT) is in
; permuted order.
;
; RDIAG is in permuted order.
;
; ACNORM is in standard parameter order.
;
; NOTE: in IDL the factors appear slightly differently than described
; above.  The matrix A is still m x n where m >= n.  
;
; The "upper" triangular matrix R is actually stored in the strict
; lower left triangle of A under the standard notation of IDL.
;
; The reflectors that generate Q are in the upper trapezoid of A upon
; output.
;
;  EXAMPLE:  decompose the matrix [[9.,2.,6.],[4.,8.,7.]]
;    aa = [[9.,2.,6.],[4.,8.,7.]]
;    mpfit_qrfac, aa, aapvt, rdiag, aanorm
;     IDL> print, aa
;          1.81818*     0.181818*     0.545455*
;         -8.54545+      1.90160*     0.432573*
;     IDL> print, rdiag
;         -11.0000+     -7.48166+
;
; The components marked with a * are the components of the
; reflectors, and those marked with a + are components of R.
;
; To reconstruct Q and R we proceed as follows.  First R.
;    r = fltarr(m, n)
;    for i = 0, n-1 do r(0:i,i) = aa(0:i,i)  ; fill in lower diag
;    r(lindgen(n)*(m+1)) = rdiag
;
; Next, Q, which are composed from the reflectors.  Each reflector v
; is taken from the upper trapezoid of aa, and converted to a matrix
; via (I - 2 vT . v / (v . vT)).
;
;   hh = ident                                    ;; identity matrix
;   for i = 0, n-1 do begin
;    v = aa(*,i) & if i GT 0 then v(0:i-1) = 0    ;; extract reflector
;    hh = hh ## (ident - 2*(v # v)/total(v * v))  ;; generate matrix
;   endfor
;
; Test the result:
;    IDL> print, hh ## transpose(r)
;          9.00000      4.00000
;          2.00000      8.00000
;          6.00000      7.00000
;
; Note that it is usually never necessary to form the Q matrix
; explicitly, and MPFIT does not.

pro mpfit_qrfac, a, ipvt, rdiag, acnorm, pivot=pivot

  COMPILE_OPT strictarr
  sz = size(a)
  m = sz[1]
  n = sz[2]

  common mpfit_machar, machvals
  common mpfit_profile, profvals
;  prof_start = systime(1)

  MACHEP0 = machvals.machep
  DWARF   = machvals.minnum
  
  ;; Compute the initial column norms and initialize arrays
  acnorm = make_array(n, value=a[0]*0.)
  for j = 0L, n-1 do $
    acnorm[j] = mpfit_enorm(a[*,j])
  rdiag = acnorm
  wa = rdiag
  ipvt = lindgen(n)

  ;; Reduce a to r with householder transformations
  minmn = min([m,n])
  for j = 0L, minmn-1 do begin
      if NOT keyword_set(pivot) then goto, HOUSE1
      
      ;; Bring the column of largest norm into the pivot position
      rmax = max(rdiag[j:*])
      kmax = where(rdiag[j:*] EQ rmax, ct) + j
      if ct LE 0 then goto, HOUSE1
      kmax = kmax[0]
      
      ;; Exchange rows via the pivot only.  Avoid actually exchanging
      ;; the rows, in case there is lots of memory transfer.  The
      ;; exchange occurs later, within the body of MPFIT, after the
      ;; extraneous columns of the matrix have been shed.
      if kmax NE j then begin
          temp     = ipvt[j]   & ipvt[j]    = ipvt[kmax] & ipvt[kmax]  = temp
          rdiag[kmax] = rdiag[j]
          wa[kmax]    = wa[j]
      endif
      
      HOUSE1:

      ;; Compute the householder transformation to reduce the jth
      ;; column of A to a multiple of the jth unit vector
      lj     = ipvt[j]
      ajj    = a[j:*,lj]
      ajnorm = mpfit_enorm(ajj)
      if ajnorm EQ 0 then goto, NEXT_ROW
      if a[j,lj] LT 0 then ajnorm = -ajnorm
      
      ajj     = ajj / ajnorm
      ajj[0]  = ajj[0] + 1
      ;; *** Note optimization a(j:*,j)
      a[j,lj] = ajj
      
      ;; Apply the transformation to the remaining columns
      ;; and update the norms

      ;; NOTE to SELF: tried to optimize this by removing the loop,
      ;; but it actually got slower.  Reverted to "for" loop to keep
      ;; it simple.
      if j+1 LT n then begin
          for k=j+1, n-1 do begin
              lk = ipvt[k]
              ajk = a[j:*,lk]
              ;; *** Note optimization a(j:*,lk) 
              ;; (corrected 20 Jul 2000)
              if a[j,lj] NE 0 then $
                a[j,lk] = ajk - ajj * total(ajk*ajj)/a[j,lj]

              if keyword_set(pivot) AND rdiag[k] NE 0 then begin
                  temp = a[j,lk]/rdiag[k]
                  rdiag[k] = rdiag[k] * sqrt((1.-temp^2) > 0)
                  temp = rdiag[k]/wa[k]
                  if 0.05D*temp*temp LE MACHEP0 then begin
                      rdiag[k] = mpfit_enorm(a[j+1:*,lk])
                      wa[k] = rdiag[k]
                  endif
              endif
          endfor
      endif

      NEXT_ROW:
      rdiag[j] = -ajnorm
  endfor

;  profvals.qrfac = profvals.qrfac + (systime(1) - prof_start)
  return
end

;     **********
;
;     subroutine qrsolv
;
;     given an m by n matrix a, an n by n diagonal matrix d,
;     and an m-vector b, the problem is to determine an x which
;     solves the system
;
;           a*x = b ,     d*x = 0 ,
;
;     in the least squares sense.
;
;     this subroutine completes the solution of the problem
;     if it is provided with the necessary information from the
;     qr factorization, with column pivoting, of a. that is, if
;     a*p = q*r, where p is a permutation matrix, q has orthogonal
;     columns, and r is an upper triangular matrix with diagonal
;     elements of nonincreasing magnitude, then qrsolv expects
;     the full upper triangle of r, the permutation matrix p,
;     and the first n components of (q transpose)*b. the system
;     a*x = b, d*x = 0, is then equivalent to
;
;                  t       t
;           r*z = q *b ,  p *d*p*z = 0 ,
;
;     where x = p*z. if this system does not have full rank,
;     then a least squares solution is obtained. on output qrsolv
;     also provides an upper triangular matrix s such that
;
;            t   t               t
;           p *(a *a + d*d)*p = s *s .
;
;     s is computed within qrsolv and may be of separate interest.
;
;     the subroutine statement is
;
;       subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
;
;     where
;
;       n is a positive integer input variable set to the order of r.
;
;       r is an n by n array. on input the full upper triangle
;         must contain the full upper triangle of the matrix r.
;         on output the full upper triangle is unaltered, and the
;         strict lower triangle contains the strict upper triangle
;         (transposed) of the upper triangular matrix s.
;
;       ldr is a positive integer input variable not less than n
;         which specifies the leading dimension of the array r.
;
;       ipvt is an integer input array of length n which defines the
;         permutation matrix p such that a*p = q*r. column j of p
;         is column ipvt(j) of the identity matrix.
;
;       diag is an input array of length n which must contain the
;         diagonal elements of the matrix d.
;
;       qtb is an input array of length n which must contain the first
;         n elements of the vector (q transpose)*b.
;
;       x is an output array of length n which contains the least
;         squares solution of the system a*x = b, d*x = 0.
;
;       sdiag is an output array of length n which contains the
;         diagonal elements of the upper triangular matrix s.
;
;       wa is a work array of length n.
;
;     subprograms called
;
;       fortran-supplied ... dabs,dsqrt
;
;     argonne national laboratory. minpack project. march 1980.
;     burton s. garbow, kenneth e. hillstrom, jorge j. more
;
pro mpfit_qrsolv, r, ipvt, diag, qtb, x, sdiag

  COMPILE_OPT strictarr
  sz = size(r)
  m = sz[1]
  n = sz[2]
  delm = lindgen(n) * (m+1) ;; Diagonal elements of r

  common mpfit_profile, profvals
;  prof_start = systime(1)

  ;; copy r and (q transpose)*b to preserve input and initialize s.
  ;; in particular, save the diagonal elements of r in x.

  for j = 0L, n-1 do $
    r[j:n-1,j] = r[j,j:n-1]
  x = r[delm]
  wa = qtb
  ;; Below may look strange, but it's so we can keep the right precision
  zero = qtb[0]*0.
  half = zero + 0.5
  quart = zero + 0.25

  ;; Eliminate the diagonal matrix d using a givens rotation
  for j = 0L, n-1 do begin
      l = ipvt[j]
      if diag[l] EQ 0 then goto, STORE_RESTORE
      sdiag[j:*] = 0
      sdiag[j] = diag[l]

      ;; The transformations to eliminate the row of d modify only a
      ;; single element of (q transpose)*b beyond the first n, which
      ;; is initially zero.

      qtbpj = zero
      for k = j, n-1 do begin
          if sdiag[k] EQ 0 then goto, ELIM_NEXT_LOOP
          if abs(r[k,k]) LT abs(sdiag[k]) then begin
              cotan  = r[k,k]/sdiag[k]
              sine   = half/sqrt(quart + quart*cotan*cotan)
              cosine = sine*cotan
          endif else begin
              tang   = sdiag[k]/r[k,k]
              cosine = half/sqrt(quart + quart*tang*tang)
              sine   = cosine*tang
          endelse
          
          ;; Compute the modified diagonal element of r and the
          ;; modified element of ((q transpose)*b,0).
          r[k,k] = cosine*r[k,k] + sine*sdiag[k]
          temp = cosine*wa[k] + sine*qtbpj
          qtbpj = -sine*wa[k] + cosine*qtbpj
          wa[k] = temp

          ;; Accumulate the transformation in the row of s
          if n GT k+1 then begin
              temp = cosine*r[k+1:n-1,k] + sine*sdiag[k+1:n-1]
              sdiag[k+1:n-1] = -sine*r[k+1:n-1,k] + cosine*sdiag[k+1:n-1]
              r[k+1:n-1,k] = temp
          endif
ELIM_NEXT_LOOP:
      endfor

STORE_RESTORE:
      sdiag[j] = r[j,j]
      r[j,j] = x[j]
  endfor

  ;; Solve the triangular system for z.  If the system is singular
  ;; then obtain a least squares solution
  nsing = n
  wh = where(sdiag EQ 0, ct)
  if ct GT 0 then begin
      nsing = wh[0]
      wa[nsing:*] = 0
  endif

  if nsing GE 1 then begin
      wa[nsing-1] = wa[nsing-1]/sdiag[nsing-1] ;; Degenerate case
      ;; *** Reverse loop ***
      for j=nsing-2,0,-1 do begin  
          sum = total(r[j+1:nsing-1,j]*wa[j+1:nsing-1])
          wa[j] = (wa[j]-sum)/sdiag[j]
      endfor
  endif

  ;; Permute the components of z back to components of x
  x[ipvt] = wa

;  profvals.qrsolv = profvals.qrsolv + (systime(1) - prof_start)
  return
end
      
  
;
;     subroutine lmpar
;
;     given an m by n matrix a, an n by n nonsingular diagonal
;     matrix d, an m-vector b, and a positive number delta,
;     the problem is to determine a value for the parameter
;     par such that if x solves the system
;
;	    a*x = b ,	  sqrt(par)*d*x = 0 ,
;
;     in the least squares sense, and dxnorm is the euclidean
;     norm of d*x, then either par is zero and
;
;	    (dxnorm-delta) .le. 0.1*delta ,
;
;     or par is positive and
;
;	    abs(dxnorm-delta) .le. 0.1*delta .
;
;     this subroutine completes the solution of the problem
;     if it is provided with the necessary information from the
;     qr factorization, with column pivoting, of a. that is, if
;     a*p = q*r, where p is a permutation matrix, q has orthogonal
;     columns, and r is an upper triangular matrix with diagonal
;     elements of nonincreasing magnitude, then lmpar expects
;     the full upper triangle of r, the permutation matrix p,
;     and the first n components of (q transpose)*b. on output
;     lmpar also provides an upper triangular matrix s such that
;
;	     t	 t		     t
;	    p *(a *a + par*d*d)*p = s *s .
;
;     s is employed within lmpar and may be of separate interest.
;
;     only a few iterations are generally needed for convergence
;     of the algorithm. if, however, the limit of 10 iterations
;     is reached, then the output par will contain the best
;     value obtained so far.
;
;     the subroutine statement is
;
;	subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
;			 wa1,wa2)
;
;     where
;
;	n is a positive integer input variable set to the order of r.
;
;	r is an n by n array. on input the full upper triangle
;	  must contain the full upper triangle of the matrix r.
;	  on output the full upper triangle is unaltered, and the
;	  strict lower triangle contains the strict upper triangle
;	  (transposed) of the upper triangular matrix s.
;
;	ldr is a positive integer input variable not less than n
;	  which specifies the leading dimension of the array r.
;
;	ipvt is an integer input array of length n which defines the
;	  permutation matrix p such that a*p = q*r. column j of p
;	  is column ipvt(j) of the identity matrix.
;
;	diag is an input array of length n which must contain the
;	  diagonal elements of the matrix d.
;
;	qtb is an input array of length n which must contain the first
;	  n elements of the vector (q transpose)*b.
;
;	delta is a positive input variable which specifies an upper
;	  bound on the euclidean norm of d*x.
;
;	par is a nonnegative variable. on input par contains an
;	  initial estimate of the levenberg-marquardt parameter.
;	  on output par contains the final estimate.
;
;	x is an output array of length n which contains the least
;	  squares solution of the system a*x = b, sqrt(par)*d*x = 0,
;	  for the output par.
;
;	sdiag is an output array of length n which contains the
;	  diagonal elements of the upper triangular matrix s.
;
;	wa1 and wa2 are work arrays of length n.
;
;     subprograms called
;
;	minpack-supplied ... dpmpar,enorm,qrsolv
;
;	fortran-supplied ... dabs,dmax1,dmin1,dsqrt
;
;     argonne national laboratory. minpack project. march 1980.
;     burton s. garbow, kenneth e. hillstrom, jorge j. more
;
function mpfit_lmpar, r, ipvt, diag, qtb, delta, x, sdiag, par=par

  COMPILE_OPT strictarr
  common mpfit_machar, machvals
  common mpfit_profile, profvals
;  prof_start = systime(1)

  MACHEP0 = machvals.machep
  DWARF   = machvals.minnum

  sz = size(r)
  m = sz[1]
  n = sz[2]
  delm = lindgen(n) * (m+1) ;; Diagonal elements of r

  ;; Compute and store in x the gauss-newton direction.  If the
  ;; jacobian is rank-deficient, obtain a least-squares solution
  nsing = n
  wa1 = qtb
  rthresh = max(abs(r[delm]))*MACHEP0
  wh = where(abs(r[delm]) LT rthresh, ct)
  if ct GT 0 then begin
      nsing = wh[0]
      wa1[wh[0]:*] = 0
  endif

  if nsing GE 1 then begin
      ;; *** Reverse loop ***
      for j=nsing-1,0,-1 do begin  
          wa1[j] = wa1[j]/r[j,j]
          if (j-1 GE 0) then $
            wa1[0:(j-1)] = wa1[0:(j-1)] - r[0:(j-1),j]*wa1[j]
      endfor
  endif

  ;; Note: ipvt here is a permutation array
  x[ipvt] = wa1

  ;; Initialize the iteration counter.  Evaluate the function at the
  ;; origin, and test for acceptance of the gauss-newton direction
  iter = 0L
  wa2 = diag * x
  dxnorm = mpfit_enorm(wa2)
  fp = dxnorm - delta
  if fp LE 0.1*delta then goto, TERMINATE

  ;; If the jacobian is not rank deficient, the newton step provides a
  ;; lower bound, parl, for the zero of the function.  Otherwise set
  ;; this bound to zero.
  
  zero = wa2[0]*0.
  parl = zero
  if nsing GE n then begin
      wa1 = diag[ipvt]*wa2[ipvt]/dxnorm

      wa1[0] = wa1[0] / r[0,0] ;; Degenerate case 
      for j=1L, n-1 do begin   ;; Note "1" here, not zero
          sum = total(r[0:(j-1),j]*wa1[0:(j-1)])
          wa1[j] = (wa1[j] - sum)/r[j,j]
      endfor

      temp = mpfit_enorm(wa1)
      parl = ((fp/delta)/temp)/temp
  endif

  ;; Calculate an upper bound, paru, for the zero of the function
  for j=0L, n-1 do begin
      sum = total(r[0:j,j]*qtb[0:j])
      wa1[j] = sum/diag[ipvt[j]]
  endfor
  gnorm = mpfit_enorm(wa1)
  paru  = gnorm/delta
  if paru EQ 0 then paru = DWARF/min([delta,0.1])

  ;; If the input par lies outside of the interval (parl,paru), set
  ;; par to the closer endpoint

  par = max([par,parl])
  par = min([par,paru])
  if par EQ 0 then par = gnorm/dxnorm

  ;; Beginning of an interation
  ITERATION:
  iter = iter + 1
  
  ;; Evaluate the function at the current value of par
  if par EQ 0 then par = max([DWARF, paru*0.001])
  temp = sqrt(par)
  wa1 = temp * diag
  mpfit_qrsolv, r, ipvt, wa1, qtb, x, sdiag
  wa2 = diag*x
  dxnorm = mpfit_enorm(wa2)
  temp = fp
  fp = dxnorm - delta

  if (abs(fp) LE 0.1D*delta) $
    OR ((parl EQ 0) AND (fp LE temp) AND (temp LT 0)) $
    OR (iter EQ 10) then goto, TERMINATE

  ;; Compute the newton correction
  wa1 = diag[ipvt]*wa2[ipvt]/dxnorm

  for j=0L,n-2 do begin
      wa1[j] = wa1[j]/sdiag[j]
      wa1[j+1:n-1] = wa1[j+1:n-1] - r[j+1:n-1,j]*wa1[j]
  endfor
  wa1[n-1] = wa1[n-1]/sdiag[n-1] ;; Degenerate case

  temp = mpfit_enorm(wa1)
  parc = ((fp/delta)/temp)/temp

  ;; Depending on the sign of the function, update parl or paru
  if fp GT 0 then parl = max([parl,par])
  if fp LT 0 then paru = min([paru,par])

  ;; Compute an improved estimate for par
  par = max([parl, par+parc])

  ;; End of an iteration
  goto, ITERATION
  
TERMINATE:
  ;; Termination
;  profvals.lmpar = profvals.lmpar + (systime(1) - prof_start)
  if iter EQ 0 then return, par[0]*0.
  return, par
end

;; Procedure to tie one parameter to another.
pro mpfit_tie, p, _ptied
  COMPILE_OPT strictarr
  if n_elements(_ptied) EQ 0 then return
  if n_elements(_ptied) EQ 1 then if _ptied[0] EQ '' then return
  for _i = 0L, n_elements(_ptied)-1 do begin
      if _ptied[_i] EQ '' then goto, NEXT_TIE
      _cmd = 'p['+strtrim(_i,2)+'] = '+_ptied[_i]
      _err = execute(_cmd)
      if _err EQ 0 then begin
          message, 'ERROR: Tied expression "'+_cmd+'" failed.'
          return
      endif
      NEXT_TIE:
  endfor
end

;; Default print procedure
pro mpfit_defprint, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, $
                    p11, p12, p13, p14, p15, p16, p17, p18, $
                    format=format, unit=unit0, _EXTRA=extra

  COMPILE_OPT strictarr
  if n_elements(unit0) EQ 0 then unit = -1 else unit = round(unit0[0])
  if n_params() EQ 0 then printf, unit, '' $
  else if n_params() EQ 1 then printf, unit, p1, format=format $
  else if n_params() EQ 2 then printf, unit, p1, p2, format=format $
  else if n_params() EQ 3 then printf, unit, p1, p2, p3, format=format $
  else if n_params() EQ 4 then printf, unit, p1, p2, p4, format=format 

  return
end


;; Default procedure to be called every iteration.  It simply prints
;; the parameter values.
pro mpfit_defiter, fcn, x, iter, fnorm, FUNCTARGS=fcnargs, $
                   quiet=quiet, iterstop=iterstop, iterkeybyte=iterkeybyte, $
                   parinfo=parinfo, iterprint=iterprint0, $
                   format=fmt, pformat=pformat, dof=dof0, _EXTRA=iterargs

  COMPILE_OPT strictarr
  common mpfit_error, mperr
  mperr = 0

  if keyword_set(quiet) then goto, DO_ITERSTOP
  if n_params() EQ 3 then begin
      fvec = mpfit_call(fcn, x, _EXTRA=fcnargs)
      fnorm = mpfit_enorm(fvec)^2
  endif

  ;; Determine which parameters to print
  nprint = n_elements(x)
  iprint = lindgen(nprint)

  if n_elements(iterprint0) EQ 0 then iterprint = 'MPFIT_DEFPRINT' $
  else iterprint = strtrim(iterprint0[0],2)

  if n_elements(dof0) EQ 0 then dof = 1L else dof = floor(dof0[0])
  call_procedure, iterprint, iter, fnorm, dof, $
    format='("Iter ",I6,"   CHI-SQUARE = ",G15.8,"          DOF = ",I0)', $
    _EXTRA=iterargs
  if n_elements(fmt) GT 0 then begin
      call_procedure, iterprint, x, format=fmt, _EXTRA=iterargs
  endif else begin
      if n_elements(pformat) EQ 0 then pformat = '(G20.6)'
      parname = 'P('+strtrim(iprint,2)+')'
      pformats = strarr(nprint) + pformat

      if n_elements(parinfo) GT 0 then begin
          parinfo_tags = tag_names(parinfo)
          wh = where(parinfo_tags EQ 'PARNAME', ct)
          if ct EQ 1 then begin
              wh = where(parinfo.parname NE '', ct)
              if ct GT 0 then $
                parname[wh] = strmid(parinfo[wh].parname,0,25)
          endif
          wh = where(parinfo_tags EQ 'MPPRINT', ct)
          if ct EQ 1 then begin
              iprint = where(parinfo.mpprint EQ 1, nprint)
              if nprint EQ 0 then goto, DO_ITERSTOP
          endif
          wh = where(parinfo_tags EQ 'MPFORMAT', ct)
          if ct EQ 1 then begin
              wh = where(parinfo.mpformat NE '', ct)
              if ct GT 0 then pformats[wh] = parinfo[wh].mpformat
          endif
      endif

      for i = 0L, nprint-1 do begin
          call_procedure, iterprint, parname[iprint[i]], x[iprint[i]], $
            format='("    ",A0," = ",'+pformats[iprint[i]]+')', $
            _EXTRA=iterargs
      endfor
  endelse

  DO_ITERSTOP:
  if n_elements(iterkeybyte) EQ 0 then iterkeybyte = 7b
  if keyword_set(iterstop) then begin
      k = get_kbrd(0)
      if k EQ string(iterkeybyte[0]) then begin
          message, 'WARNING: minimization not complete', /info
          print, 'Do you want to terminate this procedure? (y/n)', $
            format='(A,$)'
          k = ''
          read, k
          if strupcase(strmid(k,0,1)) EQ 'Y' then begin
              message, 'WARNING: Procedure is terminating.', /info
              mperr = -1
          endif
      endif
  endif

  return
end

;; Procedure to parse the parameter values in PARINFO
pro mpfit_parinfo, parinfo, tnames, tag, values, default=def, status=status, $
                   n_param=n

  COMPILE_OPT strictarr
  status = 0
  if n_elements(n) EQ 0 then n = n_elements(parinfo)

  if n EQ 0 then begin
      if n_elements(def) EQ 0 then return
      values = def
      status = 1
      return
  endif

  if n_elements(parinfo) EQ 0 then goto, DO_DEFAULT
  if n_elements(tnames) EQ 0 then tnames = tag_names(parinfo)
  wh = where(tnames EQ tag, ct)

  if ct EQ 0 then begin
      DO_DEFAULT:
      if n_elements(def) EQ 0 then return
      values = make_array(n, value=def[0])
      values[0] = def
  endif else begin
      values = parinfo.(wh[0])
      np = n_elements(parinfo)
      nv = n_elements(values)
      values = reform(values[*], nv/np, np)
  endelse

  status = 1
  return
end


;     **********
;
;     subroutine covar
;
;     given an m by n matrix a, the problem is to determine
;     the covariance matrix corresponding to a, defined as
;
;                    t
;           inverse(a *a) .
;
;     this subroutine completes the solution of the problem
;     if it is provided with the necessary information from the
;     qr factorization, with column pivoting, of a. that is, if
;     a*p = q*r, where p is a permutation matrix, q has orthogonal
;     columns, and r is an upper triangular matrix with diagonal
;     elements of nonincreasing magnitude, then covar expects
;     the full upper triangle of r and the permutation matrix p.
;     the covariance matrix is then computed as
;
;                      t     t
;           p*inverse(r *r)*p  .
;
;     if a is nearly rank deficient, it may be desirable to compute
;     the covariance matrix corresponding to the linearly independent
;     columns of a. to define the numerical rank of a, covar uses
;     the tolerance tol. if l is the largest integer such that
;
;           abs(r(l,l)) .gt. tol*abs(r(1,1)) ,
;
;     then covar computes the covariance matrix corresponding to
;     the first l columns of r. for k greater than l, column
;     and row ipvt(k) of the covariance matrix are set to zero.
;
;     the subroutine statement is
;
;       subroutine covar(n,r,ldr,ipvt,tol,wa)
;
;     where
;
;       n is a positive integer input variable set to the order of r.
;
;       r is an n by n array. on input the full upper triangle must
;         contain the full upper triangle of the matrix r. on output
;         r contains the square symmetric covariance matrix.
;
;       ldr is a positive integer input variable not less than n
;         which specifies the leading dimension of the array r.
;
;       ipvt is an integer input array of length n which defines the
;         permutation matrix p such that a*p = q*r. column j of p
;         is column ipvt(j) of the identity matrix.
;
;       tol is a nonnegative input variable used to define the
;         numerical rank of a in the manner described above.
;
;       wa is a work array of length n.
;
;     subprograms called
;
;       fortran-supplied ... dabs
;
;     argonne national laboratory. minpack project. august 1980.
;     burton s. garbow, kenneth e. hillstrom, jorge j. more
;
;     **********
function mpfit_covar, rr, ipvt, tol=tol

  COMPILE_OPT strictarr
  sz = size(rr)
  if sz[0] NE 2 then begin
      message, 'ERROR: r must be a two-dimensional matrix'
      return, -1L
  endif
  n = sz[1]
  if n NE sz[2] then begin
      message, 'ERROR: r must be a square matrix'
      return, -1L
  endif

  zero = rr[0] * 0.
  one  = zero  + 1.
  if n_elements(ipvt) EQ 0 then ipvt = lindgen(n)
  r = rr
  r = reform(rr, n, n, /overwrite)
  
  ;; Form the inverse of r in the full upper triangle of r
  l = -1L
  if n_elements(tol) EQ 0 then tol = one*1.E-14
  tolr = tol * abs(r[0,0])
  for k = 0L, n-1 do begin
      if abs(r[k,k]) LE tolr then goto, INV_END_LOOP
      r[k,k] = one/r[k,k]
      for j = 0L, k-1 do begin
          temp = r[k,k] * r[j,k]
          r[j,k] = zero
          r[0,k] = r[0:j,k] - temp*r[0:j,j]
      endfor
      l = k
  endfor
  INV_END_LOOP:

  ;; Form the full upper triangle of the inverse of (r transpose)*r
  ;; in the full upper triangle of r
  if l GE 0 then $
    for k = 0L, l do begin
      for j = 0L, k-1 do begin
          temp = r[j,k]
          r[0,j] = r[0:j,j] + temp*r[0:j,k]
      endfor
      temp = r[k,k]
      r[0,k] = temp * r[0:k,k]
  endfor

  ;; Form the full lower triangle of the covariance matrix
  ;; in the strict lower triangle of r and in wa
  wa = replicate(r[0,0], n)
  for j = 0L, n-1 do begin
      jj = ipvt[j]
      sing = j GT l
      for i = 0L, j do begin
          if sing then r[i,j] = zero
          ii = ipvt[i]
          if ii GT jj then r[ii,jj] = r[i,j]
          if ii LT jj then r[jj,ii] = r[i,j]
      endfor
      wa[jj] = r[j,j]
  endfor

  ;; Symmetrize the covariance matrix in r
  for j = 0L, n-1 do begin
      r[0:j,j] = r[j,0:j]
      r[j,j] = wa[j]
  endfor

  return, r
end

;; Parse the RCSID revision number
function mpfit_revision
  ;; NOTE: this string is changed every time an RCS check-in occurs
  revision = '$Revision: 1.82 $'

  ;; Parse just the version number portion
  revision = stregex(revision,'\$'+'Revision: *([0-9.]+) *'+'\$',/extract,/sub)
  revision = revision[1]
  return, revision
end

;; Parse version numbers of the form 'X.Y'
function mpfit_parse_version, version
  sz = size(version)
  if sz[sz[0]+1] NE 7 then return, 0

  s = stregex(version[0], '^([0-9]+)\.([0-9]+)$', /extract,/sub) 
  if s[0] NE version[0] then return, 0
  return, long(s[1:2])
end

;; Enforce a minimum version number
function mpfit_min_version, version, min_version
  mv = mpfit_parse_version(min_version)
  if mv[0] EQ 0 then return, 0
  v  = mpfit_parse_version(version)

  ;; Compare version components
  if v[0] LT mv[0] then return, 0
  if v[1] LT mv[1] then return, 0
  return, 1
end

; Manually reset recursion fencepost if the user gets in trouble
pro mpfit_reset_recursion
  common mpfit_fencepost, mpfit_fencepost_active
  mpfit_fencepost_active = 0
end

;     **********
;
;     subroutine lmdif
;
;     the purpose of lmdif is to minimize the sum of the squares of
;     m nonlinear functions in n variables by a modification of
;     the levenberg-marquardt algorithm. the user must provide a
;     subroutine which calculates the functions. the jacobian is
;     then calculated by a forward-difference approximation.
;
;     the subroutine statement is
;
;	subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
;			 diag,mode,factor,nprint,info,nfev,fjac,
;			 ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4)
;
;     where
;
;	fcn is the name of the user-supplied subroutine which
;	  calculates the functions. fcn must be declared
;	  in an external statement in the user calling
;	  program, and should be written as follows.
;
;	  subroutine fcn(m,n,x,fvec,iflag)
;	  integer m,n,iflag
;	  double precision x(n),fvec(m)
;	  ----------
;	  calculate the functions at x and
;	  return this vector in fvec.
;	  ----------
;	  return
;	  end
;
;	  the value of iflag should not be changed by fcn unless
;	  the user wants to terminate execution of lmdif.
;	  in this case set iflag to a negative integer.
;
;	m is a positive integer input variable set to the number
;	  of functions.
;
;	n is a positive integer input variable set to the number
;	  of variables. n must not exceed m.
;
;	x is an array of length n. on input x must contain
;	  an initial estimate of the solution vector. on output x
;	  contains the final estimate of the solution vector.
;
;	fvec is an output array of length m which contains
;	  the functions evaluated at the output x.
;
;	ftol is a nonnegative input variable. termination
;	  occurs when both the actual and predicted relative
;	  reductions in the sum of squares are at most ftol.
;	  therefore, ftol measures the relative error desired
;	  in the sum of squares.
;
;	xtol is a nonnegative input variable. termination
;	  occurs when the relative error between two consecutive
;	  iterates is at most xtol. therefore, xtol measures the
;	  relative error desired in the approximate solution.
;
;	gtol is a nonnegative input variable. termination
;	  occurs when the cosine of the angle between fvec and
;	  any column of the jacobian is at most gtol in absolute
;	  value. therefore, gtol measures the orthogonality
;	  desired between the function vector and the columns
;	  of the jacobian.
;
;	maxfev is a positive integer input variable. termination
;	  occurs when the number of calls to fcn is at least
;	  maxfev by the end of an iteration.
;
;	epsfcn is an input variable used in determining a suitable
;	  step length for the forward-difference approximation. this
;	  approximation assumes that the relative errors in the
;	  functions are of the order of epsfcn. if epsfcn is less
;	  than the machine precision, it is assumed that the relative
;	  errors in the functions are of the order of the machine
;	  precision.
;
;	diag is an array of length n. if mode = 1 (see
;	  below), diag is internally set. if mode = 2, diag
;	  must contain positive entries that serve as
;	  multiplicative scale factors for the variables.
;
;	mode is an integer input variable. if mode = 1, the
;	  variables will be scaled internally. if mode = 2,
;	  the scaling is specified by the input diag. other
;	  values of mode are equivalent to mode = 1.
;
;	factor is a positive input variable used in determining the
;	  initial step bound. this bound is set to the product of
;	  factor and the euclidean norm of diag*x if nonzero, or else
;	  to factor itself. in most cases factor should lie in the
;	  interval (.1,100.). 100. is a generally recommended value.
;
;	nprint is an integer input variable that enables controlled
;	  printing of iterates if it is positive. in this case,
;	  fcn is called with iflag = 0 at the beginning of the first
;	  iteration and every nprint iterations thereafter and
;	  immediately prior to return, with x and fvec available
;	  for printing. if nprint is not positive, no special calls
;	  of fcn with iflag = 0 are made.
;
;	info is an integer output variable. if the user has
;	  terminated execution, info is set to the (negative)
;	  value of iflag. see description of fcn. otherwise,
;	  info is set as follows.
;
;	  info = 0  improper input parameters.
;
;	  info = 1  both actual and predicted relative reductions
;		    in the sum of squares are at most ftol.
;
;	  info = 2  relative error between two consecutive iterates
;		    is at most xtol.
;
;	  info = 3  conditions for info = 1 and info = 2 both hold.
;
;	  info = 4  the cosine of the angle between fvec and any
;		    column of the jacobian is at most gtol in
;		    absolute value.
;
;	  info = 5  number of calls to fcn has reached or
;		    exceeded maxfev.
;
;	  info = 6  ftol is too small. no further reduction in
;		    the sum of squares is possible.
;
;	  info = 7  xtol is too small. no further improvement in
;		    the approximate solution x is possible.
;
;	  info = 8  gtol is too small. fvec is orthogonal to the
;		    columns of the jacobian to machine precision.
;
;	nfev is an integer output variable set to the number of
;	  calls to fcn.
;
;	fjac is an output m by n array. the upper n by n submatrix
;	  of fjac contains an upper triangular matrix r with
;	  diagonal elements of nonincreasing magnitude such that
;
;		 t     t	   t
;		p *(jac *jac)*p = r *r,
;
;	  where p is a permutation matrix and jac is the final
;	  calculated jacobian. column j of p is column ipvt(j)
;	  (see below) of the identity matrix. the lower trapezoidal
;	  part of fjac contains information generated during
;	  the computation of r.
;
;	ldfjac is a positive integer input variable not less than m
;	  which specifies the leading dimension of the array fjac.
;
;	ipvt is an integer output array of length n. ipvt
;	  defines a permutation matrix p such that jac*p = q*r,
;	  where jac is the final calculated jacobian, q is
;	  orthogonal (not stored), and r is upper triangular
;	  with diagonal elements of nonincreasing magnitude.
;	  column j of p is column ipvt(j) of the identity matrix.
;
;	qtf is an output array of length n which contains
;	  the first n elements of the vector (q transpose)*fvec.
;
;	wa1, wa2, and wa3 are work arrays of length n.
;
;	wa4 is a work array of length m.
;
;     subprograms called
;
;	user-supplied ...... fcn
;
;	minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac
;
;	fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod
;
;     argonne national laboratory. minpack project. march 1980.
;     burton s. garbow, kenneth e. hillstrom, jorge j. more
;
;     **********
function mpfit, fcn, xall, FUNCTARGS=fcnargs, SCALE_FCN=scalfcn, $
                ftol=ftol0, xtol=xtol0, gtol=gtol0, epsfcn=epsfcn, $
                resdamp=damp0, $
                nfev=nfev, maxiter=maxiter, errmsg=errmsg, $
                factor=factor0, nprint=nprint0, STATUS=info, $
                iterproc=iterproc0, iterargs=iterargs, iterstop=ss,$
                iterkeystop=iterkeystop, $
                niter=iter, nfree=nfree, npegged=npegged, dof=dof, $
                diag=diag, rescale=rescale, autoderivative=autoderiv0, $
                pfree_index=ifree, $
                perror=perror, covar=covar, nocovar=nocovar, $
                bestnorm=fnorm, best_resid=fvec, $
                best_fjac=output_fjac, calc_fjac=calc_fjac, $
                parinfo=parinfo, quiet=quiet, nocatch=nocatch, $
                fastnorm=fastnorm0, proc=proc, query=query, $
                external_state=state, external_init=extinit, $
                external_fvec=efvec, external_fjac=efjac, $
                version=version, min_version=min_version0

  COMPILE_OPT strictarr
  info = 0L
  errmsg = ''

  ;; Compute the revision number, to be returned in the VERSION and
  ;; QUERY keywords.
  common mpfit_revision_common, mpfit_revision_str
  if n_elements(mpfit_revision_str) EQ 0 then $
     mpfit_revision_str = mpfit_revision()
  version = mpfit_revision_str

  if keyword_set(query) then begin
     if n_elements(min_version0) GT 0 then $
        if mpfit_min_version(version, min_version0[0]) EQ 0 then $
           return, 0
     return, 1
  endif

  if n_elements(min_version0) GT 0 then $
     if mpfit_min_version(version, min_version0[0]) EQ 0 then begin
     message, 'ERROR: minimum required version '+min_version0[0]+' not satisfied', /info
     return, !values.d_nan
  endif

  if n_params() EQ 0 then begin
      message, "USAGE: PARMS = MPFIT('MYFUNCT', START_PARAMS, ... )", /info
      return, !values.d_nan
  endif
  
  ;; Use of double here not a problem since f/x/gtol are all only used
  ;; in comparisons
  if n_elements(ftol0) EQ 0 then ftol = 1.D-10 else ftol = ftol0[0]
  if n_elements(xtol0) EQ 0 then xtol = 1.D-10 else xtol = xtol0[0]
  if n_elements(gtol0) EQ 0 then gtol = 1.D-10 else gtol = gtol0[0]
  if n_elements(factor0) EQ 0 then factor = 100. else factor = factor0[0]
  if n_elements(nprint0) EQ 0 then nprint = 1 else nprint = nprint0[0]
  if n_elements(iterproc0) EQ 0 then iterproc = 'MPFIT_DEFITER' else iterproc = iterproc0[0]
  if n_elements(autoderiv0) EQ 0 then autoderiv = 1 else autoderiv = autoderiv0[0]
  if n_elements(fastnorm0) EQ 0 then fastnorm = 0 else fastnorm = fastnorm0[0]
  if n_elements(damp0) EQ 0 then damp = 0 else damp = damp0[0]

  ;; These are special configuration parameters that can't be easily
  ;; passed by MPFIT directly.
  ;;  FASTNORM - decide on which sum-of-squares technique to use (1)
  ;;             is fast, (0) is slower
  ;;  PROC - user routine is a procedure (1) or function (0)
  ;;  QANYTIED - set to 1 if any parameters are TIED, zero if none
  ;;  PTIED - array of strings, one for each parameter
  common mpfit_config, mpconfig
  mpconfig = {fastnorm: keyword_set(fastnorm), proc: 0, nfev: 0L, damp: damp}
  common mpfit_machar, machvals

  iflag = 0L
  catch_msg = 'in MPFIT'
  nfree = 0L
  npegged = 0L
  dof = 0L
  output_fjac = 0L

  ;; Set up a persistent fencepost that prevents recursive calls
  common mpfit_fencepost, mpfit_fencepost_active
  if n_elements(mpfit_fencepost_active) EQ 0 then mpfit_fencepost_active = 0
  if mpfit_fencepost_active then begin
      errmsg = 'ERROR: recursion detected; you cannot run MPFIT recursively'
      goto, TERMINATE
  endif
  ;; Only activate the fencepost if we are not in debugging mode
  if NOT keyword_set(nocatch) then mpfit_fencepost_active = 1


  ;; Parameter damping doesn't work when user is providing their own
  ;; gradients.
  if damp NE 0 AND NOT keyword_set(autoderiv) then begin
      errmsg = 'ERROR: keywords DAMP and AUTODERIV are mutually exclusive'
      goto, TERMINATE
  endif      
  
  ;; Process the ITERSTOP and ITERKEYSTOP keywords, and turn this into
  ;; a set of keywords to pass to MPFIT_DEFITER.
  if strupcase(iterproc) EQ 'MPFIT_DEFITER' AND n_elements(iterargs) EQ 0 $
    AND keyword_set(ss) then begin
      if n_elements(iterkeystop) GT 0 then begin
          sz = size(iterkeystop)
          tp = sz[sz[0]+1]
          if tp EQ 7 then begin
              ;; String - convert first char to byte
              iterkeybyte = (byte(iterkeystop[0]))[0]
          endif
          if (tp GE 1 AND tp LE 3) OR (tp GE 12 AND tp LE 15) then begin
              ;; Integer - convert to byte
              iterkeybyte = byte(iterkeystop[0])
          endif
          if n_elements(iterkeybyte) EQ 0 then begin
              errmsg = 'ERROR: ITERKEYSTOP must be either a BYTE or STRING'
              goto, TERMINATE
          endif

          iterargs = {iterstop: 1, iterkeybyte: iterkeybyte}
      endif else begin
          iterargs = {iterstop: 1, iterkeybyte: 7b}
      endelse
  endif


  ;; Handle error conditions gracefully
  if NOT keyword_set(nocatch) then begin
      catch, catcherror
      if catcherror NE 0 then begin  ;; An error occurred!!!
          catch, /cancel
          mpfit_fencepost_active = 0
          err_string = ''+!error_state.msg
          message, /cont, 'Error detected while '+catch_msg+':'
          message, /cont,    err_string
          message, /cont, 'Error condition detected. Returning to MAIN level.'
          if errmsg EQ '' then $
            errmsg = 'Error detected while '+catch_msg+': '+err_string
          if info EQ 0 then info = -18
          return, !values.d_nan
      endif
  endif
  mpconfig = create_struct(mpconfig, 'NOCATCH', keyword_set(nocatch))

  ;; Parse FCN function name - be sure it is a scalar string
  sz = size(fcn)
  if sz[0] NE 0 then begin
      FCN_NAME:
      errmsg = 'ERROR: MYFUNCT must be a scalar string'
      goto, TERMINATE
  endif
  if sz[sz[0]+1] NE 7 then goto, FCN_NAME

  isext = 0
  if fcn EQ '(EXTERNAL)' then begin
      if n_elements(efvec) EQ 0 OR n_elements(efjac) EQ 0 then begin
          errmsg = 'ERROR: when using EXTERNAL function, EXTERNAL_FVEC '+$
            'and EXTERNAL_FJAC must be defined'
          goto, TERMINATE
      endif
      nv = n_elements(efvec)
      nj = n_elements(efjac)
      if (nj MOD nv) NE 0 then begin
          errmsg = 'ERROR: the number of values in EXTERNAL_FJAC must be '+ $
            'a multiple of the number of values in EXTERNAL_FVEC'
          goto, TERMINATE
      endif
      isext = 1
  endif

  ;; Parinfo:
  ;; --------------- STARTING/CONFIG INFO (passed in to routine, not changed)
  ;; .value   - starting value for parameter
  ;; .fixed   - parameter is fixed
  ;; .limited - a two-element array, if parameter is bounded on
  ;;            lower/upper side
  ;; .limits - a two-element array, lower/upper parameter bounds, if
  ;;           limited vale is set
  ;; .step   - step size in Jacobian calc, if greater than zero

  catch_msg = 'parsing input parameters'
  ;; Parameters can either be stored in parinfo, or x.  Parinfo takes
  ;; precedence if it exists.
  if n_elements(xall) EQ 0 AND n_elements(parinfo) EQ 0 then begin
      errmsg = 'ERROR: must pass parameters in P or PARINFO'
      goto, TERMINATE
  endif

  ;; Be sure that PARINFO is of the right type
  if n_elements(parinfo) GT 0 then begin
      ;; Make sure the array is 1-D
      parinfo = parinfo[*]
      parinfo_size = size(parinfo)
      if parinfo_size[parinfo_size[0]+1] NE 8 then begin
          errmsg = 'ERROR: PARINFO must be a structure.'
          goto, TERMINATE
      endif
      if n_elements(xall) GT 0 AND n_elements(xall) NE n_elements(parinfo) $
        then begin
          errmsg = 'ERROR: number of elements in PARINFO and P must agree'
          goto, TERMINATE
      endif
  endif

  ;; If the parameters were not specified at the command line, then
  ;; extract them from PARINFO
  if n_elements(xall) EQ 0 then begin
      mpfit_parinfo, parinfo, tagnames, 'VALUE', xall, status=status
      if status EQ 0 then begin
          errmsg = 'ERROR: either P or PARINFO[*].VALUE must be supplied.'
          goto, TERMINATE
      endif

      sz = size(xall)
      ;; Convert to double if parameters are not float or double
      if sz[sz[0]+1] NE 4 AND sz[sz[0]+1] NE 5 then $
        xall = double(xall)
  endif
  xall = xall[*]   ;; Make sure the array is 1-D
  npar = n_elements(xall)
  zero = xall[0] * 0.
  one  = zero    + 1.
  fnorm  = -one
  fnorm1 = -one

  ;; TIED parameters?
  mpfit_parinfo, parinfo, tagnames, 'TIED', ptied, default='', n=npar
  ptied = strtrim(ptied, 2)
  wh = where(ptied NE '', qanytied) 
  qanytied = qanytied GT 0
  mpconfig = create_struct(mpconfig, 'QANYTIED', qanytied, 'PTIED', ptied)

  ;; FIXED parameters ?
  mpfit_parinfo, parinfo, tagnames, 'FIXED', pfixed, default=0, n=npar
  pfixed = pfixed EQ 1
  pfixed = pfixed OR (ptied NE '');; Tied parameters are also effectively fixed
  
  ;; Finite differencing step, absolute and relative, and sidedness of deriv.
  mpfit_parinfo, parinfo, tagnames, 'STEP',     step, default=zero, n=npar
  mpfit_parinfo, parinfo, tagnames, 'RELSTEP', dstep, default=zero, n=npar
  mpfit_parinfo, parinfo, tagnames, 'MPSIDE',  dside, default=0,    n=npar
  ;; Debugging parameters
  mpfit_parinfo, parinfo, tagnames, 'MPDERIV_DEBUG',  ddebug, default=0, n=npar
  mpfit_parinfo, parinfo, tagnames, 'MPDERIV_RELTOL', ddrtol, default=zero, n=npar
  mpfit_parinfo, parinfo, tagnames, 'MPDERIV_ABSTOL', ddatol, default=zero, n=npar

  ;; Maximum and minimum steps allowed to be taken in one iteration
  mpfit_parinfo, parinfo, tagnames, 'MPMAXSTEP', maxstep, default=zero, n=npar
  mpfit_parinfo, parinfo, tagnames, 'MPMINSTEP', minstep, default=zero, n=npar
  qmin = minstep *  0  ;; Remove minstep for now!!
  qmax = maxstep NE 0
  wh = where(qmin AND qmax AND maxstep LT minstep, ct)
  if ct GT 0 then begin
      errmsg = 'ERROR: MPMINSTEP is greater than MPMAXSTEP'
      goto, TERMINATE
  endif

  ;; Finish up the free parameters
  ifree = where(pfixed NE 1, nfree)
  if nfree EQ 0 then begin
      errmsg = 'ERROR: no free parameters'
      goto, TERMINATE
  endif

  ;; An external Jacobian must be checked against the number of
  ;; parameters
  if isext then begin
      if (nj/nv) NE nfree then begin
          errmsg = string(nv, nfree, nfree, $
           format=('("ERROR: EXTERNAL_FJAC must be a ",I0," x ",I0,' + $
                   '" array, where ",I0," is the number of free parameters")'))
          goto, TERMINATE
      endif
  endif

  ;; Compose only VARYING parameters
  xnew = xall      ;; xnew is the set of parameters to be returned
  x = xnew[ifree]  ;; x is the set of free parameters
  ; Same for min/max step diagnostics
  qmin = qmin[ifree]  & minstep = minstep[ifree]
  qmax = qmax[ifree]  & maxstep = maxstep[ifree]
  wh = where(qmin OR qmax, ct)
  qminmax = ct GT 0


  ;; LIMITED parameters ?
  mpfit_parinfo, parinfo, tagnames, 'LIMITED', limited, status=st1
  mpfit_parinfo, parinfo, tagnames, 'LIMITS',  limits,  status=st2
  if st1 EQ 1 AND st2 EQ 1 then begin

      ;; Error checking on limits in parinfo
      wh = where((limited[0,*] AND xall LT limits[0,*]) OR $
                 (limited[1,*] AND xall GT limits[1,*]), ct)
      if ct GT 0 then begin
          errmsg = 'ERROR: parameters are not within PARINFO limits'
          goto, TERMINATE
      endif
      wh = where(limited[0,*] AND limited[1,*] AND $
                 limits[0,*] GE limits[1,*] AND $
                 pfixed EQ 0, ct)
      if ct GT 0 then begin
          errmsg = 'ERROR: PARINFO parameter limits are not consistent'
          goto, TERMINATE
      endif
      

      ;; Transfer structure values to local variables
      qulim = limited[1, ifree]
      ulim  = limits [1, ifree]
      qllim = limited[0, ifree]
      llim  = limits [0, ifree]

      wh = where(qulim OR qllim, ct)
      if ct GT 0 then qanylim = 1 else qanylim = 0

  endif else begin

      ;; Fill in local variables with dummy values
      qulim = lonarr(nfree)
      ulim  = x * 0.
      qllim = qulim
      llim  = x * 0.
      qanylim = 0

  endelse

  ;; Initialize the number of parameters pegged at a hard limit value
  wh = where((qulim AND (x EQ ulim)) OR (qllim AND (x EQ llim)), npegged)

  n = n_elements(x)
  if n_elements(maxiter) EQ 0 then maxiter = 200L

  ;; Check input parameters for errors
  if (n LE 0) OR (ftol LE 0) OR (xtol LE 0) OR (gtol LE 0) $
    OR (maxiter LT 0) OR (factor LE 0) then begin
      errmsg = 'ERROR: input keywords are inconsistent'
      goto, TERMINATE
  endif

  if keyword_set(rescale) then begin
      errmsg = 'ERROR: DIAG parameter scales are inconsistent'
      if n_elements(diag) LT n then goto, TERMINATE
      wh = where(diag LE 0, ct)
      if ct GT 0 then goto, TERMINATE
      errmsg = ''
  endif

  if n_elements(state) NE 0 AND NOT keyword_set(extinit) then begin
      szst = size(state)
      if szst[szst[0]+1] NE 8  then begin
          errmsg = 'EXTERNAL_STATE keyword was not preserved'
          status = 0
          goto, TERMINATE
      endif
      if nfree NE n_elements(state.ifree) then begin
          BAD_IFREE:
          errmsg = 'Number of free parameters must not change from one '+$
            'external iteration to the next'
          status = 0
          goto, TERMINATE
      endif
      wh = where(ifree NE state.ifree, ct)
      if ct GT 0 then goto, BAD_IFREE

      tnames = tag_names(state)
      for i = 0L, n_elements(tnames)-1 do begin
          dummy = execute(tnames[i]+' = state.'+tnames[i])
      endfor
      wa4 = reform(efvec, n_elements(efvec))

      goto, RESUME_FIT
  endif

  common mpfit_error, mperr

  if NOT isext then begin
      mperr = 0
      catch_msg = 'calling '+fcn
      fvec = mpfit_call(fcn, xnew, _EXTRA=fcnargs)
      iflag = mperr
      if iflag LT 0 then begin
          errmsg = 'ERROR: first call to "'+fcn+'" failed'
          goto, TERMINATE
      endif
  endif else begin
      fvec = reform(efvec, n_elements(efvec))
  endelse

  catch_msg = 'calling MPFIT_SETMACHAR'
  sz = size(fvec[0])
  isdouble = (sz[sz[0]+1] EQ 5)
  
  mpfit_setmachar, double=isdouble

  common mpfit_profile, profvals
;  prof_start = systime(1)

  MACHEP0 = machvals.machep
  DWARF   = machvals.minnum

  szx = size(x)
  ;; The parameters and the squared deviations should have the same
  ;; type.  Otherwise the MACHAR-based evaluation will fail.
  catch_msg = 'checking parameter data'
  tp = szx[szx[0]+1]
  if tp NE 4 AND tp NE 5 then begin
      if NOT keyword_set(quiet) then begin
          message, 'WARNING: input parameters must be at least FLOAT', /info
          message, '         (converting parameters to FLOAT)', /info
      endif
      x = float(x)
      xnew = float(x)
      szx = size(x)
  endif
  if isdouble AND tp NE 5 then begin
      if NOT keyword_set(quiet) then begin
          message, 'WARNING: data is DOUBLE but parameters are FLOAT', /info
          message, '         (converting parameters to DOUBLE)', /info
      endif
      x = double(x)
      xnew = double(xnew)
  endif

  m = n_elements(fvec)
  if (m LT n) then begin
      errmsg = 'ERROR: number of parameters must not exceed data'
      goto, TERMINATE
  endif

  fnorm = mpfit_enorm(fvec)

  ;; Initialize Levelberg-Marquardt parameter and iteration counter

  par = zero
  iter = 1L
  qtf = x * 0.

  ;; Beginning of the outer loop
  
  OUTER_LOOP:

  ;; If requested, call fcn to enable printing of iterates
  xnew[ifree] = x
  if qanytied then mpfit_tie, xnew, ptied
  dof = (n_elements(fvec) - nfree) > 1L

  if nprint GT 0 AND iterproc NE '' then begin
      catch_msg = 'calling '+iterproc
      iflag = 0L
      if (iter-1) MOD nprint EQ 0 then begin
          mperr = 0
          xnew0 = xnew

          call_procedure, iterproc, fcn, xnew, iter, fnorm^2, $
            FUNCTARGS=fcnargs, parinfo=parinfo, quiet=quiet, $
            dof=dof, _EXTRA=iterargs
          iflag = mperr

          ;; Check for user termination
          if iflag LT 0 then begin  
              errmsg = 'WARNING: premature termination by "'+iterproc+'"'
              goto, TERMINATE
          endif

          ;; If parameters were changed (grrr..) then re-tie
          if max(abs(xnew0-xnew)) GT 0 then begin
              if qanytied then mpfit_tie, xnew, ptied
              x = xnew[ifree]
          endif

      endif
  endif

  ;; Calculate the jacobian matrix
  iflag = 2
  if NOT isext then begin
      catch_msg = 'calling MPFIT_FDJAC2'
      ;; NOTE!  If you change this call then change the one during
      ;; clean-up as well!
      fjac = mpfit_fdjac2(fcn, x, fvec, step, qulim, ulim, dside, $
                          iflag=iflag, epsfcn=epsfcn, $
                          autoderiv=autoderiv, dstep=dstep, $
                          FUNCTARGS=fcnargs, ifree=ifree, xall=xnew, $
                          deriv_debug=ddebug, deriv_reltol=ddrtol, deriv_abstol=ddatol)
      if iflag LT 0 then begin
          errmsg = 'WARNING: premature termination by FDJAC2'
          goto, TERMINATE
      endif
  endif else begin
      fjac = reform(efjac,n_elements(fvec),npar, /overwrite)
  endelse

  ;; Rescale the residuals and gradient, for use with "alternative"
  ;; statistics such as the Cash statistic.
  catch_msg = 'prescaling residuals and gradient'
  if n_elements(scalfcn) GT 0 then begin
      call_procedure, strtrim(scalfcn[0],2), fvec, fjac
  endif

  ;; Determine if any of the parameters are pegged at the limits
  npegged = 0L
  if qanylim then begin
      catch_msg = 'zeroing derivatives of pegged parameters'
      whlpeg = where(qllim AND (x EQ llim), nlpeg)
      whupeg = where(qulim AND (x EQ ulim), nupeg)
      npegged = nlpeg + nupeg
      
      ;; See if any "pegged" values should keep their derivatives
      if (nlpeg GT 0) then begin
          ;; Total derivative of sum wrt lower pegged parameters
          ;;   Note: total(fvec*fjac[*,i]) is d(CHI^2)/dX[i]
          for i = 0L, nlpeg-1 do begin
              sum = total(fvec * fjac[*,whlpeg[i]])
              if sum GT 0 then fjac[*,whlpeg[i]] = 0
          endfor
      endif
      if (nupeg GT 0) then begin
          ;; Total derivative of sum wrt upper pegged parameters
          for i = 0L, nupeg-1 do begin
              sum = total(fvec * fjac[*,whupeg[i]])
              if sum LT 0 then fjac[*,whupeg[i]] = 0
          endfor
      endif
  endif

  ;; Save a copy of the Jacobian if the user requests it...
  if keyword_set(calc_fjac) then output_fjac = fjac

  ;; =====================
  ;; Compute the QR factorization of the jacobian
  catch_msg = 'calling MPFIT_QRFAC'
  ;;  IN:      Jacobian        
  ;; OUT:      Hh Vects  Permutation  RDIAG  ACNORM
  mpfit_qrfac, fjac,     ipvt,        wa1,   wa2, /pivot
  ;; Jacobian - jacobian matrix computed by mpfit_fdjac2
  ;; Hh vects - house holder vectors from QR factorization & R matrix
  ;; Permutation - permutation vector for pivoting
  ;; RDIAG - diagonal elements of R matrix
  ;; ACNORM - norms of input Jacobian matrix before factoring

  ;; =====================
  ;; On the first iteration if "diag" is unspecified, scale
  ;; according to the norms of the columns of the initial jacobian
  catch_msg = 'rescaling diagonal elements'
  if (iter EQ 1) then begin
      ;; Input: WA2 = root sum of squares of original Jacobian matrix
      ;;        DIAG = user-requested diagonal (not documented!)
      ;;        FACTOR = user-requested norm factor (not documented!)
      ;; Output: DIAG = Diagonal scaling values
      ;;         XNORM = sum of squared scaled residuals
      ;;         DELTA = rescaled XNORM

      if NOT keyword_set(rescale) OR (n_elements(diag) LT n) then begin
          diag = wa2 ;; Calculated from original Jacobian
          wh = where (diag EQ 0, ct) ;; Handle zero values
          if ct GT 0 then diag[wh] = one
      endif
      
      ;; On the first iteration, calculate the norm of the scaled x
      ;; and initialize the step bound delta 
      wa3 = diag * x           ;; WA3 is temp variable
      xnorm = mpfit_enorm(wa3)
      delta = factor*xnorm
      if delta EQ zero then delta = zero + factor
  endif

  ;; Form (q transpose)*fvec and store the first n components in qtf
  catch_msg = 'forming (q transpose)*fvec'
  wa4 = fvec
  for j=0L, n-1 do begin
      lj = ipvt[j]
      temp3 = fjac[j,lj]
      if temp3 NE 0 then begin
          fj = fjac[j:*,lj]
          wj = wa4[j:*]
          ;; *** optimization wa4(j:*)
          wa4[j] = wj - fj * total(fj*wj) / temp3  
      endif
      fjac[j,lj] = wa1[j]
      qtf[j] = wa4[j]
  endfor
  ;; From this point on, only the square matrix, consisting of the
  ;; triangle of R, is needed.
  fjac = fjac[0:n-1, 0:n-1]
  fjac = reform(fjac, n, n, /overwrite)
  fjac = fjac[*, ipvt]                    ;; Convert to permuted order
  fjac = reform(fjac, n, n, /overwrite)

  ;; Check for overflow.  This should be a cheap test here since FJAC
  ;; has been reduced to a (small) square matrix, and the test is
  ;; O(N^2).
  wh = where(finite(fjac) EQ 0, ct)
  if ct GT 0 then goto, FAIL_OVERFLOW

  ;; Compute the norm of the scaled gradient
  catch_msg = 'computing the scaled gradient'
  gnorm = zero
  if fnorm NE 0 then begin
      for j=0L, n-1 do begin
          l = ipvt[j]
          if wa2[l] NE 0 then begin
              sum = total(fjac[0:j,j]*qtf[0:j])/fnorm
              gnorm = max([gnorm,abs(sum/wa2[l])])
          endif
      endfor
  endif

  ;; Test for convergence of the gradient norm
  if gnorm LE gtol then info = 4
  if info NE 0 then goto, TERMINATE
  if maxiter EQ 0 then begin
     info = 5
     goto, TERMINATE
  endif

  ;; Rescale if necessary
  if NOT keyword_set(rescale) then $
    diag = diag > wa2

  ;; Beginning of the inner loop
  INNER_LOOP:
  
  ;; Determine the levenberg-marquardt parameter
  catch_msg = 'calculating LM parameter (MPFIT_LMPAR)'
  par = mpfit_lmpar(fjac, ipvt, diag, qtf, delta, wa1, wa2, par=par)

  ;; Store the direction p and x+p. Calculate the norm of p
  wa1 = -wa1

  if qanylim EQ 0 AND qminmax EQ 0 then begin
      ;; No parameter limits, so just move to new position WA2
      alpha = one
      wa2 = x + wa1

  endif else begin
      
      ;; Respect the limits.  If a step were to go out of bounds, then
      ;; we should take a step in the same direction but shorter distance.
      ;; The step should take us right to the limit in that case.
      alpha = one

      if qanylim EQ 1 then begin
          ;; Do not allow any steps out of bounds
          catch_msg = 'checking for a step out of bounds'
          if nlpeg GT 0 then wa1[whlpeg] = wa1[whlpeg] > 0
          if nupeg GT 0 then wa1[whupeg] = wa1[whupeg] < 0

          dwa1 = abs(wa1) GT MACHEP0
          whl = where(dwa1 AND qllim AND (x + wa1 LT llim), lct)
          if lct GT 0 then $
            alpha = min([alpha, (llim[whl]-x[whl])/wa1[whl]])
          whu = where(dwa1 AND qulim AND (x + wa1 GT ulim), uct)
          if uct GT 0 then $
            alpha = min([alpha, (ulim[whu]-x[whu])/wa1[whu]])
      endif

      ;; Obey any max step values.

      if qminmax EQ 1 then begin
          nwa1 = wa1 * alpha
          whmax = where(qmax AND maxstep GT 0, ct)
          if ct GT 0 then begin
              mrat = max(abs(nwa1[whmax])/abs(maxstep[whmax]))
              if mrat GT 1 then alpha = alpha / mrat
          endif
      endif          

      ;; Scale the resulting vector
      wa1 = wa1 * alpha
      wa2 = x + wa1

      ;; Adjust the final output values.  If the step put us exactly
      ;; on a boundary, make sure we peg it there.
      sgnu = (ulim GE 0)*2d - 1d
      sgnl = (llim GE 0)*2d - 1d

      ;; Handles case of 
      ;;      ... nonzero *LIM ...     ... zero *LIM ...
      ulim1 = ulim*(1-sgnu*MACHEP0) - (ulim EQ 0)*MACHEP0
      llim1 = llim*(1+sgnl*MACHEP0) + (llim EQ 0)*MACHEP0

      wh = where(qulim AND (wa2 GE ulim1), ct)
      if ct GT 0 then wa2[wh] = ulim[wh]

      wh = where(qllim AND (wa2 LE llim1), ct)
      if ct GT 0 then wa2[wh] = llim[wh]
  endelse

  wa3 = diag * wa1
  pnorm = mpfit_enorm(wa3)

  ;; On the first iteration, adjust the initial step bound
  if iter EQ 1 then delta = min([delta,pnorm])

  xnew[ifree] = wa2
  if isext then goto, SAVE_STATE

  ;; Evaluate the function at x+p and calculate its norm
  mperr = 0
  catch_msg = 'calling '+fcn
  wa4 = mpfit_call(fcn, xnew, _EXTRA=fcnargs)
  iflag = mperr
  if iflag LT 0 then begin
      errmsg = 'WARNING: premature termination by "'+fcn+'"'
      goto, TERMINATE
  endif
  RESUME_FIT:
  fnorm1 = mpfit_enorm(wa4)
  
  ;; Compute the scaled actual reduction
  catch_msg = 'computing convergence criteria'
  actred = -one
  if 0.1D * fnorm1 LT fnorm then actred = - (fnorm1/fnorm)^2 + 1.

  ;; Compute the scaled predicted reduction and the scaled directional
  ;; derivative
  for j = 0L, n-1 do begin
      wa3[j] = 0
      wa3[0:j] = wa3[0:j] + fjac[0:j,j]*wa1[ipvt[j]]
  endfor

  ;; Remember, alpha is the fraction of the full LM step actually
  ;; taken
  temp1 = mpfit_enorm(alpha*wa3)/fnorm
  temp2 = (sqrt(alpha*par)*pnorm)/fnorm
  half  = zero + 0.5
  prered = temp1*temp1 + (temp2*temp2)/half
  dirder = -(temp1*temp1 + temp2*temp2)

  ;; Compute the ratio of the actual to the predicted reduction.
  ratio = zero
  tenth = zero + 0.1
  if prered NE 0 then ratio = actred/prered

  ;; Update the step bound
  if ratio LE 0.25D then begin
      if actred GE 0 then temp = half $
      else temp = half*dirder/(dirder + half*actred)
      if ((0.1D*fnorm1) GE fnorm) OR (temp LT 0.1D) then temp = tenth
      delta = temp*min([delta,pnorm/tenth])
      par = par/temp
  endif else begin
      if (par EQ 0) OR (ratio GE 0.75) then begin
          delta = pnorm/half
          par = half*par
      endif
  endelse

  ;; Test for successful iteration
  if ratio GE 0.0001 then begin
      ;; Successful iteration.  Update x, fvec, and their norms
      x = wa2
      wa2 = diag * x

      fvec = wa4
      xnorm = mpfit_enorm(wa2)
      fnorm = fnorm1
      iter = iter + 1
  endif

  ;; Tests for convergence
  if (abs(actred) LE ftol) AND (prered LE ftol) $
    AND  (0.5D * ratio LE 1) then info = 1
  if delta LE xtol*xnorm then info = 2
  if (abs(actred) LE ftol) AND (prered LE ftol) $
    AND (0.5D * ratio LE 1) AND (info EQ 2) then info = 3
  if info NE 0 then goto, TERMINATE

  ;; Tests for termination and stringent tolerances
  if iter GE maxiter then info = 5
  if (abs(actred) LE MACHEP0) AND (prered LE MACHEP0) $
    AND (0.5*ratio LE 1) then info = 6
  if delta LE MACHEP0*xnorm then info = 7
  if gnorm LE MACHEP0 then info = 8
  if info NE 0 then goto, TERMINATE

  ;; End of inner loop. Repeat if iteration unsuccessful
  if ratio LT 0.0001 then begin
      goto, INNER_LOOP
  endif

  ;; Check for over/underflow
  wh = where(finite(wa1) EQ 0 OR finite(wa2) EQ 0 OR finite(x) EQ 0, ct)
  if ct GT 0 OR finite(ratio) EQ 0 then begin
      FAIL_OVERFLOW:
      errmsg = ('ERROR: parameter or function value(s) have become '+$
                'infinite; check model function for over- '+$
                'and underflow')
      info = -16
      goto, TERMINATE
  endif

  ;; End of outer loop.
  goto, OUTER_LOOP

TERMINATE:
  catch_msg = 'in the termination phase'
  ;; Termination, either normal or user imposed.
  if iflag LT 0 then info = iflag
  iflag = 0
  if n_elements(xnew) EQ 0 then goto, FINAL_RETURN
  if nfree EQ 0 then xnew = xall else xnew[ifree] = x
  if n_elements(qanytied) GT 0 then if qanytied then mpfit_tie, xnew, ptied
  dof = n_elements(fvec) - nfree


  ;; Call the ITERPROC at the end of the fit, if the fit status is
  ;; okay.  Don't call it if the fit failed for some reason.
  if info GT 0 then begin
      
      mperr = 0
      xnew0 = xnew
      
      call_procedure, iterproc, fcn, xnew, iter, fnorm^2, $
        FUNCTARGS=fcnargs, parinfo=parinfo, quiet=quiet, $
        dof=dof, _EXTRA=iterargs
      iflag = mperr

      if iflag LT 0 then begin  
          errmsg = 'WARNING: premature termination by "'+iterproc+'"'
      endif else begin
          ;; If parameters were changed (grrr..) then re-tie
          if max(abs(xnew0-xnew)) GT 0 then begin
              if qanytied then mpfit_tie, xnew, ptied
              x = xnew[ifree]
          endif
      endelse

  endif

  ;; Initialize the number of parameters pegged at a hard limit value
  npegged = 0L
  if n_elements(qanylim) GT 0 then if qanylim then begin
      wh = where((qulim AND (x EQ ulim)) OR $
                 (qllim AND (x EQ llim)), npegged)
  endif

  ;; Calculate final function value (FNORM) and residuals (FVEC)
  if isext EQ 0 AND nprint GT 0 AND info GT 0 then begin
      catch_msg = 'calling '+fcn
      fvec = mpfit_call(fcn, xnew, _EXTRA=fcnargs)
      catch_msg = 'in the termination phase'
      fnorm = mpfit_enorm(fvec)
  endif

  if n_elements(fnorm) GT 0 AND n_elements(fnorm1) GT 0 then begin
      fnorm = max([fnorm, fnorm1])
      fnorm = fnorm^2.
  endif

  covar = !values.d_nan
  ;; (very carefully) set the covariance matrix COVAR
  if info GT 0 AND NOT keyword_set(nocovar) $
    AND n_elements(n) GT 0 $
    AND n_elements(fjac) GT 0 AND n_elements(ipvt) GT 0 then begin
      sz = size(fjac)
      if n GT 0 AND sz[0] GT 1 AND sz[1] GE n AND sz[2] GE n $
        AND n_elements(ipvt) GE n then begin
          catch_msg = 'computing the covariance matrix'
          if n EQ 1 then $
            cv = mpfit_covar(reform([fjac[0,0]],1,1), ipvt[0]) $
          else $
            cv = mpfit_covar(fjac[0:n-1,0:n-1], ipvt[0:n-1])
          cv = reform(cv, n, n, /overwrite)
          nn = n_elements(xall)
          
          ;; Fill in actual covariance matrix, accounting for fixed
          ;; parameters.
          covar = replicate(zero, nn, nn)
          for i = 0L, n-1 do begin
              covar[ifree, ifree[i]] = cv[*,i]
          end
          
          ;; Compute errors in parameters
          catch_msg = 'computing parameter errors'
          i = lindgen(nn)
          perror = replicate(abs(covar[0])*0., nn)
          wh = where(covar[i,i] GE 0, ct)
          if ct GT 0 then $
            perror[wh] = sqrt(covar[wh, wh])
      endif
  endif

;  catch_msg = 'returning the result'
;  profvals.mpfit = profvals.mpfit + (systime(1) - prof_start)

  FINAL_RETURN:
  mpfit_fencepost_active = 0
  nfev = mpconfig.nfev
  if n_elements(xnew) EQ 0 then return, !values.d_nan
  return, xnew

  
  ;; ------------------------------------------------------------------
  ;; Alternate ending if the user supplies the function and gradients
  ;; externally
  ;; ------------------------------------------------------------------

  SAVE_STATE:

  catch_msg = 'saving MPFIT state'

  ;; Names of variables to save
  varlist = ['alpha', 'delta', 'diag', 'dwarf', 'factor', 'fnorm', $
             'fjac', 'gnorm', 'nfree', 'ifree', 'ipvt', 'iter', $
             'm', 'n', 'machvals', 'machep0', 'npegged', $
             'whlpeg', 'whupeg', 'nlpeg', 'nupeg', $
             'mpconfig', 'par', 'pnorm', 'qtf', $
             'wa1', 'wa2', 'wa3', 'xnorm', 'x', 'xnew']
  cmd = ''

  ;; Construct an expression that will save them
  for i = 0L, n_elements(varlist)-1 do begin
      ival = 0
      dummy = execute('ival = n_elements('+varlist[i]+')')
      if ival GT 0 then begin
          cmd = cmd + ',' + varlist[i]+':'+varlist[i]
      endif
  endfor
  cmd = 'state = create_struct({'+strmid(cmd,1)+'})'
  state = 0

  if execute(cmd) NE 1 then $
    message, 'ERROR: could not save MPFIT state'

  ;; Set STATUS keyword to prepare for next iteration, and reset init
  ;; so we do not init the next time
  info = 9
  extinit = 0

  return, xnew

end

;+
; NAME:
;   MPFIT2DFUN
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Perform Levenberg-Marquardt least-squares fit to a 2-D IDL function
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   parms = MPFIT2DFUN(MYFUNCT, X, Y, Z, ERR, start_parms, ...)
;
; DESCRIPTION:
;
;  MPFIT2DFUN fits a user-supplied model -- in the form of an IDL
;  function -- to a set of user-supplied data.  MPFIT2DFUN calls
;  MPFIT, the MINPACK-1 least-squares minimizer, to do the main
;  work.  MPFIT2DFUN is a specialized version for two-dimensional 
;  data.
;
;  Given the data and their uncertainties, MPFIT2DFUN finds the best set
;  of model parameters which match the data (in a least-squares
;  sense) and returns them in an array.
;  
;  The user must supply the following items:
;   - Two arrays of independent variable values ("X", "Y").
;   - An array of "measured" *dependent* variable values ("Z").
;   - An array of "measured" 1-sigma uncertainty values ("ERR").
;   - The name of an IDL function which computes Z given (X,Y) ("MYFUNCT").
;   - Starting guesses for all of the parameters ("START_PARAMS").
;
;  There are very few restrictions placed on X, Y, Z, or MYFUNCT.
;  Simply put, MYFUNCT must map the (X,Y) values into Z values given
;  the model parameters.  The (X,Y) values are usually the independent
;  X and Y coordinate positions in the two dimensional plane, but need
;  not be.
;
;  MPFIT2DFUN carefully avoids passing large arrays where possible to
;  improve performance.
;
;  See below for an example of usage.
;   
; USER FUNCTION
;
;  The user must define a function which returns the model value.  For
;  applications which use finite-difference derivatives -- the default
;  -- the user function should be declared in the following way:
;
;    FUNCTION MYFUNCT, X, Y, P
;     ; The independent variables are X and Y
;     ; Parameter values are passed in "P"
;     ZMOD = ... computed model values at (X,Y) ...
;     return, ZMOD
;    END
;
;  The returned array YMOD must have the same dimensions and type as
;  the "measured" Z values.
;
;  User functions may also indicate a fatal error condition
;  using the ERROR_CODE common block variable, as described
;  below under the MPFIT_ERROR common block definition.
;
;  See the discussion under "ANALYTIC DERIVATIVES" and AUTODERIVATIVE
;  in MPFIT.PRO if you wish to compute the derivatives for yourself.
;  AUTODERIVATIVE is accepted and passed directly to MPFIT.  The user
;  function must accept one additional parameter, DP, which contains
;  the derivative of the user function with respect to each parameter
;  at each data point, as described in MPFIT.PRO.
;
; CREATING APPROPRIATELY DIMENSIONED INDEPENDENT VARIABLES
;
;  The user must supply appropriate independent variables to
;  MPFIT2DFUN.  For image fitting applications, this variable should
;  be two-dimensional *arrays* describing the X and Y positions of
;  every *pixel*.  [ Thus any two dimensional sampling is permitted,
;  including irregular sampling. ]
;  
;  If the sampling is regular, then the x coordinates are the same for
;  each row, and the y coordinates are the same for each column.  Call
;  the x-row and y-column coordinates XR and YC respectively.  You can
;  then compute X and Y as follows:
;  
;      X = XR # (YC*0 + 1)             eqn. 1
;      Y = (XR*0 + 1) # YC             eqn. 2
;  
;  For example, if XR and YC have the following values:
;  
;    XR = [  1, 2, 3, 4, 5,]  ;; X positions of one row of pixels
;    YC = [ 15,16,17 ]        ;; Y positions of one column of
;                                pixels
;  
;  Then using equations 1 and 2 above will give these values to X and
;  Y:
;  
;     X :  1  2  3  4  5       ;; X positions of all pixels
;          1  2  3  4  5
;          1  2  3  4  5
;  
;     Y : 15 15 15 15 15       ;; Y positions of all pixels
;         16 16 16 16 16
;         17 17 17 17 17
;  
;  Using the above technique is suggested, but *not* required.  You
;  can do anything you wish with the X and Y values.  This technique
;  only makes it easier to compute your model function values.
;
; CONSTRAINING PARAMETER VALUES WITH THE PARINFO KEYWORD
;
;  The behavior of MPFIT can be modified with respect to each
;  parameter to be fitted.  A parameter value can be fixed; simple
;  boundary constraints can be imposed; limitations on the parameter
;  changes can be imposed; properties of the automatic derivative can
;  be modified; and parameters can be tied to one another.
;
;  These properties are governed by the PARINFO structure, which is
;  passed as a keyword parameter to MPFIT.
;
;  PARINFO should be an array of structures, one for each parameter.
;  Each parameter is associated with one element of the array, in
;  numerical order.  The structure can have the following entries
;  (none are required):
;  
;     .VALUE - the starting parameter value (but see the START_PARAMS
;              parameter for more information).
;  
;     .FIXED - a boolean value, whether the parameter is to be held
;              fixed or not.  Fixed parameters are not varied by
;              MPFIT, but are passed on to MYFUNCT for evaluation.
;  
;     .LIMITED - a two-element boolean array.  If the first/second
;                element is set, then the parameter is bounded on the
;                lower/upper side.  A parameter can be bounded on both
;                sides.  Both LIMITED and LIMITS must be given
;                together.
;  
;     .LIMITS - a two-element float or double array.  Gives the
;               parameter limits on the lower and upper sides,
;               respectively.  Zero, one or two of these values can be
;               set, depending on the values of LIMITED.  Both LIMITED
;               and LIMITS must be given together.
;  
;     .PARNAME - a string, giving the name of the parameter.  The
;                fitting code of MPFIT does not use this tag in any
;                way.  However, the default ITERPROC will print the
;                parameter name if available.
;  
;     .STEP - the step size to be used in calculating the numerical
;             derivatives.  If set to zero, then the step size is
;             computed automatically.  Ignored when AUTODERIVATIVE=0.
;             This value is superceded by the RELSTEP value.
;
;     .RELSTEP - the *relative* step size to be used in calculating
;                the numerical derivatives.  This number is the
;                fractional size of the step, compared to the
;                parameter value.  This value supercedes the STEP
;                setting.  If the parameter is zero, then a default
;                step size is chosen.
;
;     .MPSIDE - the sidedness of the finite difference when computing
;               numerical derivatives.  This field can take four
;               values:
;
;                  0 - one-sided derivative computed automatically
;                  1 - one-sided derivative (f(x+h) - f(x)  )/h
;                 -1 - one-sided derivative (f(x)   - f(x-h))/h
;                  2 - two-sided derivative (f(x+h) - f(x-h))/(2*h)
;
;              Where H is the STEP parameter described above.  The
;              "automatic" one-sided derivative method will chose a
;              direction for the finite difference which does not
;              violate any constraints.  The other methods do not
;              perform this check.  The two-sided method is in
;              principle more precise, but requires twice as many
;              function evaluations.  Default: 0.
;
;     .MPMINSTEP - the minimum change to be made in the parameter
;                  value.  During the fitting process, the parameter
;                  will be changed by multiples of this value.  The
;                  actual step is computed as:
;
;                     DELTA1 = MPMINSTEP*ROUND(DELTA0/MPMINSTEP)
;
;                  where DELTA0 and DELTA1 are the estimated parameter
;                  changes before and after this constraint is
;                  applied.  Note that this constraint should be used
;                  with care since it may cause non-converging,
;                  oscillating solutions.
;
;                  A value of 0 indicates no minimum.  Default: 0.
;
;     .MPMAXSTEP - the maximum change to be made in the parameter
;                  value.  During the fitting process, the parameter
;                  will never be changed by more than this value.
;
;                  A value of 0 indicates no maximum.  Default: 0.
;  
;     .TIED - a string expression which "ties" the parameter to other
;             free or fixed parameters.  Any expression involving
;             constants and the parameter array P are permitted.
;             Example: if parameter 2 is always to be twice parameter
;             1 then use the following: parinfo[2].tied = '2 * P[1]'.
;             Since they are totally constrained, tied parameters are
;             considered to be fixed; no errors are computed for them.
;             [ NOTE: the PARNAME can't be used in expressions. ]
;  
;  Future modifications to the PARINFO structure, if any, will involve
;  adding structure tags beginning with the two letters "MP".
;  Therefore programmers are urged to avoid using tags starting with
;  the same letters; otherwise they are free to include their own
;  fields within the PARINFO structure, and they will be ignored.
;  
;  PARINFO Example:
;  parinfo = replicate({value:0.D, fixed:0, limited:[0,0], $
;                       limits:[0.D,0]}, 5)
;  parinfo[0].fixed = 1
;  parinfo[4].limited(0) = 1
;  parinfo[4].limits(0)  = 50.D
;  parinfo[*].value = [5.7D, 2.2, 500., 1.5, 2000.]
;  
;  A total of 5 parameters, with starting values of 5.7,
;  2.2, 500, 1.5, and 2000 are given.  The first parameter
;  is fixed at a value of 5.7, and the last parameter is
;  constrained to be above 50.
;
;
; COMPATIBILITY
;
;  This function is designed to work with IDL 5.0 or greater.
;  
;  Because TIED parameters rely on the EXECUTE() function, they cannot
;  be used with the free version of the IDL Virtual Machine.
;
;
; INPUTS:
;   MYFUNCT - a string variable containing the name of an IDL
;             function.  This function computes the "model" Z values
;             given the X,Y values and model parameters, as described above.
;
;   X - Array of "X" independent variable values, as described above.
;       These values are passed directly to the fitting function
;       unmodified.
;
;   Y - Array of "Y" independent variable values, as described
;       above. X and Y should have the same data type.
;
;   Z - Array of "measured" dependent variable values.  Z should have
;       the same data type as X and Y.  The function MYFUNCT should
;       map (X,Y)->Z.
;
;   ERR - Array of "measured" 1-sigma uncertainties.  ERR should have
;         the same data type as Z.  ERR is ignored if the WEIGHTS
;         keyword is specified.
;
;   START_PARAMS - An array of starting values for each of the
;                  parameters of the model.  The number of parameters
;                  should be fewer than the number of measurements.
;                  Also, the parameters should have the same data type
;                  as the measurements (double is preferred).
;
;                  This parameter is optional if the PARINFO keyword
;                  is used (see MPFIT).  The PARINFO keyword provides
;                  a mechanism to fix or constrain individual
;                  parameters.  If both START_PARAMS and PARINFO are
;                  passed, then the starting *value* is taken from
;                  START_PARAMS, but the *constraints* are taken from
;                  PARINFO.
; 
; RETURNS:
;
;   Returns the array of best-fit parameters.
;
; KEYWORD PARAMETERS:
;
;   BESTNORM - the value of the summed, squared, weighted residuals
;              for the returned parameter values, i.e. the chi-square value.
;
;   COVAR - the covariance matrix for the set of parameters returned
;           by MPFIT.  The matrix is NxN where N is the number of
;           parameters.  The square root of the diagonal elements
;           gives the formal 1-sigma statistical errors on the
;           parameters IF errors were treated "properly" in MYFUNC.
;           Parameter errors are also returned in PERROR.
;
;           To compute the correlation matrix, PCOR, use this example:
;                  PCOR = COV * 0
;                  FOR i = 0, n-1 DO FOR j = 0, n-1 DO $
;                    PCOR[i,j] = COV[i,j]/sqrt(COV[i,i]*COV[j,j])
;           or equivalently, in vector notation,
;                  PCOR = COV / (PERROR # PERROR)
;
;           If NOCOVAR is set or MPFIT terminated abnormally, then
;           COVAR is set to a scalar with value !VALUES.D_NAN.
;
;   DOF - number of degrees of freedom, computed as
;             DOF = N_ELEMENTS(DEVIATES) - NFREE
;         Note that this doesn't account for pegged parameters (see
;         NPEGGED).
;
;   ERRMSG - a string error or warning message is returned.
;
;   FTOL - a nonnegative input variable. Termination occurs when both
;          the actual and predicted relative reductions in the sum of
;          squares are at most FTOL (and STATUS is accordingly set to
;          1 or 3).  Therefore, FTOL measures the relative error
;          desired in the sum of squares.  Default: 1D-10
;
;   FUNCTARGS - A structure which contains the parameters to be passed
;               to the user-supplied function specified by MYFUNCT via
;               the _EXTRA mechanism.  This is the way you can pass
;               additional data to your user-supplied function without
;               using common blocks.
;
;               By default, no extra parameters are passed to the
;               user-supplied function.
;
;   GTOL - a nonnegative input variable. Termination occurs when the
;          cosine of the angle between fvec and any column of the
;          jacobian is at most GTOL in absolute value (and STATUS is
;          accordingly set to 4). Therefore, GTOL measures the
;          orthogonality desired between the function vector and the
;          columns of the jacobian.  Default: 1D-10
;
;   ITERARGS - The keyword arguments to be passed to ITERPROC via the
;              _EXTRA mechanism.  This should be a structure, and is
;              similar in operation to FUNCTARGS.
;              Default: no arguments are passed.
;
;   ITERPROC - The name of a procedure to be called upon each NPRINT
;              iteration of the MPFIT routine.  It should be declared
;              in the following way:
;
;              PRO ITERPROC, MYFUNCT, p, iter, fnorm, FUNCTARGS=fcnargs, $
;                PARINFO=parinfo, QUIET=quiet, ...
;                ; perform custom iteration update
;              END
;         
;              ITERPROC must either accept all three keyword
;              parameters (FUNCTARGS, PARINFO and QUIET), or at least
;              accept them via the _EXTRA keyword.
;          
;              MYFUNCT is the user-supplied function to be minimized,
;              P is the current set of model parameters, ITER is the
;              iteration number, and FUNCTARGS are the arguments to be
;              passed to MYFUNCT.  FNORM should be the
;              chi-squared value.  QUIET is set when no textual output
;              should be printed.  See below for documentation of
;              PARINFO.
;
;              In implementation, ITERPROC can perform updates to the
;              terminal or graphical user interface, to provide
;              feedback while the fit proceeds.  If the fit is to be
;              stopped for any reason, then ITERPROC should set the
;              common block variable ERROR_CODE to negative value (see
;              MPFIT_ERROR common block below).  In principle,
;              ITERPROC should probably not modify the parameter
;              values, because it may interfere with the algorithm's
;              stability.  In practice it is allowed.
;
;              Default: an internal routine is used to print the
;                       parameter values.
;
;   MAXITER - The maximum number of iterations to perform.  If the
;             number is exceeded, then the STATUS value is set to 5
;             and MPFIT returns.
;             Default: 200 iterations
;
;   NFEV - the number of MYFUNCT function evaluations performed.
;
;   NITER - the number of iterations completed.
;
;   NOCOVAR - set this keyword to prevent the calculation of the
;             covariance matrix before returning (see COVAR)
;
;   NPRINT - The frequency with which ITERPROC is called.  A value of
;            1 indicates that ITERPROC is called with every iteration,
;            while 2 indicates every other iteration, etc.  Note that
;            several Levenberg-Marquardt attempts can be made in a
;            single iteration.
;            Default value: 1
;
;   PARINFO - Provides a mechanism for more sophisticated constraints
;             to be placed on parameter values.  When PARINFO is not
;             passed, then it is assumed that all parameters are free
;             and unconstrained.  Values in PARINFO are never 
;             modified during a call to MPFIT.
;
;             See description above for the structure of PARINFO.
;
;             Default value:  all parameters are free and unconstrained.
;
;   PERROR - The formal 1-sigma errors in each parameter, computed
;            from the covariance matrix.  If a parameter is held
;            fixed, or if it touches a boundary, then the error is
;            reported as zero.
;
;            If the fit is unweighted (i.e. no errors were given, or
;            the weights were uniformly set to unity), then PERROR
;            will probably not represent the true parameter
;            uncertainties.  *If* you can assume that the true reduced
;            chi-squared value is unity -- meaning that the fit is
;            implicitly assumed to be of good quality -- then the
;            estimated parameter uncertainties can be computed by
;            scaling PERROR by the measured chi-squared value.
;
;              DOF     = N_ELEMENTS(Z) - N_ELEMENTS(PARMS) ; deg of freedom
;              PCERROR = PERROR * SQRT(BESTNORM / DOF)   ; scaled uncertainties
;
;   QUIET - set this keyword when no textual output should be printed
;           by MPFIT
;
;   STATUS - an integer status code is returned.  All values other
;            than zero can represent success.  It can have one of the
;            following values:
;
;	   0  improper input parameters.
;         
;	   1  both actual and predicted relative reductions
;	      in the sum of squares are at most FTOL.
;         
;	   2  relative error between two consecutive iterates
;	      is at most XTOL
;         
;	   3  conditions for STATUS = 1 and STATUS = 2 both hold.
;         
;	   4  the cosine of the angle between fvec and any
;	      column of the jacobian is at most GTOL in
;	      absolute value.
;         
;	   5  the maximum number of iterations has been reached
;         
;	   6  FTOL is too small. no further reduction in
;	      the sum of squares is possible.
;         
;	   7  XTOL is too small. no further improvement in
;	      the approximate solution x is possible.
;         
;	   8  GTOL is too small. fvec is orthogonal to the
;	      columns of the jacobian to machine precision.
;
;   WEIGHTS - Array of weights to be used in calculating the
;             chi-squared value.  If WEIGHTS is specified then the ERR
;             parameter is ignored.  The chi-squared value is computed
;             as follows:
;
;                CHISQ = TOTAL( (Z-MYFUNCT(X,Y,P))^2 * ABS(WEIGHTS) )
;
;             Here are common values of WEIGHTS:
;
;                1D/ERR^2 - Normal weighting (ERR is the measurement error)
;                1D/Z     - Poisson weighting (counting statistics)
;                1D       - Unweighted
;
;   XTOL - a nonnegative input variable. Termination occurs when the
;          relative error between two consecutive iterates is at most
;          XTOL (and STATUS is accordingly set to 2 or 3).  Therefore,
;          XTOL measures the relative error desired in the approximate
;          solution.  Default: 1D-10
;
;   YFIT - the best-fit model function, as returned by MYFUNCT.
;
; EXAMPLE:
;
;   p  = [2.2D, -0.7D, 1.4D, 3000.D]
;   x  = (dindgen(200)*0.1 - 10.) # (dblarr(200) + 1)
;   y  = (dblarr(200) + 1) # (dindgen(200)*0.1 - 10.)
;   zi = gauss2(x, y, p)
;   sz = sqrt(zi>1)
;   z  = zi + randomn(seed, 200, 200) * sz
;
;   p0 = [0D, 0D, 1D, 10D]
;   p = mpfit2dfun('GAUSS2', x, y, z, sz, p0)
;   
;   Generates a synthetic data set with a Gaussian peak, and Poisson
;   statistical uncertainty.  Then the same function (but different
;   starting parameters) is fitted to the data to see how close we can
;   get.
;
;   It is especially worthy to notice that the X and Y values are
;   created as full images, so that a coordinate is attached to each
;   pixel independently.  This is the format that GAUSS2 accepts, and
;   the easiest for you to use in your own functions.
;
;
; COMMON BLOCKS:
;
;   COMMON MPFIT_ERROR, ERROR_CODE
;
;     User routines may stop the fitting process at any time by
;     setting an error condition.  This condition may be set in either
;     the user's model computation routine (MYFUNCT), or in the
;     iteration procedure (ITERPROC).
;
;     To stop the fitting, the above common block must be declared,
;     and ERROR_CODE must be set to a negative number.  After the user
;     procedure or function returns, MPFIT checks the value of this
;     common block variable and exits immediately if the error
;     condition has been set.  By default the value of ERROR_CODE is
;     zero, indicating a successful function/procedure call.
;
;
; REFERENCES:
;
;   MINPACK-1, Jorge More', available from netlib (www.netlib.org).
;   "Optimization Software Guide," Jorge More' and Stephen Wright, 
;     SIAM, *Frontiers in Applied Mathematics*, Number 14.
;
; MODIFICATION HISTORY:
;   Written, transformed from MPFITFUN, 26 Sep 1999, CM
;   Alphabetized documented keywords, 02 Oct 1999, CM
;   Added example, 02 Oct 1999, CM
;   Tried to clarify definitions of X and Y, 29 Oct 1999, CM
;   Added QUERY keyword and query checking of MPFIT, 29 Oct 1999, CM
;   Check to be sure that X, Y and Z are present, 02 Nov 1999, CM
;   Documented PERROR for unweighted fits, 03 Nov 1999, CM
;   Changed to ERROR_CODE for error condition, 28 Jan 2000, CM
;   Copying permission terms have been liberalized, 26 Mar 2000, CM
;   Propagated improvements from MPFIT, 17 Dec 2000, CM
;   Documented RELSTEP field of PARINFO (!!), CM, 25 Oct 2002
;   Add DOF keyword to return degrees of freedom, CM, 23 June 2003
;   Minor documentation adjustment, 03 Feb 2004, CM
;   Fix the example to prevent zero errorbars, 28 Mar 2005, CM
;   Defend against users supplying strangely dimensioned X and Y, 29
;     Jun 2005, CM
;   Convert to IDL 5 array syntax (!), 16 Jul 2006, CM
;   Move STRICTARR compile option inside each function/procedure, 9 Oct 2006
;   Add COMPATIBILITY section, CM, 13 Dec 2007
;
;  $Id: mpfit2dfun.pro,v 1.11 2010/04/09 04:58:35 craigm Exp $
;-
; Copyright (C) 1997-2000, 2002, 2003, 2004, 2005, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; This is the call-back function for MPFIT.  It evaluates the
; function, subtracts the data, and returns the residuals.
function mpfit2dfun_eval, p, dp, _EXTRA=extra

  COMPILE_OPT strictarr
  common mpfit2dfun_common, fcn, x, y, z, err, wts, f, fcnargs

  ;; The function is evaluated here.  There are four choices,
  ;; depending on whether (a) FUNCTARGS was passed to MPFIT2DFUN, which
  ;; is passed to this function as "hf"; or (b) the derivative
  ;; parameter "dp" is passed, meaning that derivatives should be
  ;; calculated analytically by the function itself.
  if n_elements(fcnargs) GT 0 then begin
      if n_params() GT 1 then f = call_function(fcn,x,y,p, dp, _EXTRA=fcnargs)$
      else                    f = call_function(fcn,x,y,p,     _EXTRA=fcnargs)
  endif else begin
      if n_params() GT 1 then f = call_function(fcn,x,y,p, dp) $
      else                    f = call_function(fcn,x,y,p)
  endelse

  ;; Compute the deviates, applying either errors or weights
  if n_elements(err) GT 0 then begin
      result = (z-f)/err
  endif else if n_elements(wts) GT 0 then begin
      result = (z-f)*wts
  endif else begin
      result = (z-f)
  endelse
      
  ;; Make sure the returned result is one-dimensional.
  result = reform(result, n_elements(result), /overwrite)
  return, result
  
end

function mpfit2dfun, fcn, x, y, z, err, p, WEIGHTS=wts, FUNCTARGS=fa, $
                   BESTNORM=bestnorm, nfev=nfev, STATUS=status, $
                   parinfo=parinfo, query=query, $
                   npegged=npegged, nfree=nfree, dof=dof, $
                   covar=covar, perror=perror, niter=iter, yfit=yfit, $
                   quiet=quiet, ERRMSG=errmsg, _EXTRA=extra

  COMPILE_OPT strictarr
  status = 0L
  errmsg = ''

  ;; Detect MPFIT and crash if it was not found
  catch, catcherror
  if catcherror NE 0 then begin
      MPFIT_NOTFOUND:
      catch, /cancel
      message, 'ERROR: the required function MPFIT must be in your IDL path', /info
      return, !values.d_nan
  endif
  if mpfit(/query) NE 1 then goto, MPFIT_NOTFOUND
  catch, /cancel
  if keyword_set(query) then return, 1

  if n_params() EQ 0 then begin
      message, "USAGE: PARMS = MPFIT2DFUN('MYFUNCT', X, Y, ERR, "+ $
        "START_PARAMS, ... )", /info
      return, !values.d_nan
  endif
  if n_elements(x) EQ 0 OR n_elements(y) EQ 0 OR n_elements(z) EQ 0 then begin
      message, 'ERROR: X, Y and Z must be defined', /info
      return, !values.d_nan
  endif

  ;; Use common block to pass data back and forth
  common mpfit2dfun_common, fc, xc, yc, zc, ec, wc, mc, ac
  fc = fcn & xc = x & yc = y & zc = z & mc = 0L
  ;; These optional parameters must be undefined first
  ac = 0 & dummy = size(temporary(ac))
  ec = 0 & dummy = size(temporary(ec))
  wc = 0 & dummy = size(temporary(wc))

  if n_elements(fa) GT 0 then ac = fa
  if n_elements(wts) GT 0 then begin
      wc = sqrt(abs(wts))
  endif else if n_elements(err) GT 0 then begin
      wh = where(err EQ 0, ct)
      if ct GT 0 then begin
          message, 'ERROR: ERROR value must not be zero.  Use WEIGHTS.', $
            /info
          return, !values.d_nan
      endif
      ec = err
  endif

  result = mpfit('mpfit2dfun_eval', p, $
                 parinfo=parinfo, STATUS=status, nfev=nfev, BESTNORM=bestnorm,$
                 covar=covar, perror=perror, niter=iter, $
                 nfree=nfree, npegged=npegged, dof=dof, $
                 ERRMSG=errmsg, quiet=quiet, _EXTRA=extra)

  ;; Retrieve the fit value
  yfit = temporary(mc)
  ;; Some cleanup
  xc = 0 & yc = 0 & zc = 0 & wc = 0 & ec = 0 & mc = 0 & ac = 0

  ;; Print error message if there is one.
  if NOT keyword_set(quiet) AND errmsg NE '' then $
    message, errmsg, /info

  return, result
end
;+
; NAME:
;   MPFIT2DPEAK
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Fit a gaussian, lorentzian or Moffat model to data
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   yfit = MPFIT2DPEAK(Z, A [, X, Y, /TILT ...] )
;
; DESCRIPTION:
;
;   MPFIT2DPEAK fits a gaussian, lorentzian or Moffat model using the
;   non-linear least squares fitter MPFIT.  MPFIT2DPEAK is meant to be
;   a drop-in replacement for IDL's GAUSS2DFIT function (and requires
;   MPFIT and MPFIT2DFUN).
;
;   The choice of the fitting function is determined by the keywords
;   GAUSSIAN, LORENTZIAN and MOFFAT.  By default the gaussian model
;   function is used.  [ The Moffat function is a modified Lorentzian
;   with variable power law index. ]  The two-dimensional peak has
;   independent semimajor and semiminor axes, with an optional
;   rotation term activated by setting the TILT keyword.  The baseline
;   is assumed to be a constant.
;
;      GAUSSIAN      A[0] + A[1]*exp(-0.5*u)
;      LORENTZIAN    A[0] + A[1]/(u + 1)
;      MOFFAT        A[0] + A[1]/(u + 1)^A[7]
;
;      u = ( (x-A[4])/A[2] )^2 + ( (y-A[5])/A[3] )^2
;
;         where x and y are cartesian coordinates in rotated
;         coordinate system if TILT keyword is set.
;
;   The returned parameter array elements have the following meanings:
;
;      A[0]   Constant baseline level
;      A[1]   Peak value
;      A[2]   Peak half-width (x) -- gaussian sigma or half-width at half-max
;      A[3]   Peak half-width (y) -- gaussian sigma or half-width at half-max
;      A[4]   Peak centroid (x)
;      A[5]   Peak centroid (y)
;      A[6]   Rotation angle (radians) if TILT keyword set
;      A[7]   Moffat power law index if MOFFAT keyword set
;
;   By default the initial starting values for the parameters A are
;   estimated from the data.  However, explicit starting values can be
;   supplied using the ESTIMATES keyword.  Also, error or weighting
;   values can optionally be provided; otherwise the fit is
;   unweighted.
;
; RESTRICTIONS:
;
;   If no starting parameter ESTIMATES are provided, then MPFIT2DPEAK
;   attempts to estimate them from the data.  This is not a perfect
;   science; however, the author believes that the technique
;   implemented here is more robust than the one used in IDL's
;   GAUSS2DFIT.  The author has tested cases of strong peaks, noisy
;   peaks and broad peaks, all with success.
;
;
; COMPATIBILITY
;
;  This function is designed to work with IDL 5.0 or greater.
;  
;  Because TIED parameters rely on the EXECUTE() function, they cannot
;  be used with the free version of the IDL Virtual Machine.
;
;
; INPUTS:
;
;   Z - Two dimensional array of "measured" dependent variable values.
;       Z should be of the same type and dimension as (X # Y).
;
;   X - Optional vector of x positions for a single row of Z.
;
;          X[i] should provide the x position of Z[i,*]
;
;       Default: X values are integer increments from 0 to NX-1
;
;   Y - Optional vector of y positions for a single column of Z.
;
;          Y[j] should provide the y position of Z[*,j]
;
;       Default: Y values are integer increments from 0 to NY-1
;
; OUTPUTS:
;   A - Upon return, an array of best fit parameter values.  See the
;       table above for the meanings of each parameter element.
;
;
; RETURNS:
;
;   Returns the best fitting model function as a 2D array.
;
; KEYWORDS:
;
;   ** NOTE ** Additional keywords such as PARINFO, BESTNORM, and
;              STATUS are accepted by MPFIT2DPEAK but not documented
;              here.  Please see the documentation for MPFIT for the
;              description of these advanced options.
;
;   CHISQ - the value of the summed squared residuals for the
;           returned parameter values.
;
;   CIRCULAR - if set, then the peak profile is assumed to be
;              azimuthally symmetric.  When set, the parameters A[2)
;              and A[3) will be identical and the TILT keyword will
;              have no effect.
;
;   DOF - number of degrees of freedom, computed as
;             DOF = N_ELEMENTS(DEVIATES) - NFREE
;         Note that this doesn't account for pegged parameters (see
;         NPEGGED).
;
;   ERROR - upon input, the measured 1-sigma uncertainties in the "Z"
;           values.  If no ERROR or WEIGHTS are given, then the fit is
;           unweighted.
;
;   ESTIMATES - Array of starting values for each parameter of the
;               model.  If ESTIMATES is not set, then the starting
;               values are estimated from the data directly, before
;               fitting.  (This also means that PARINFO.VALUES is
;               ignored.)
;               Default: not set - parameter values are estimated from data.
;
;   GAUSSIAN - if set, fit a gaussian model function.  The Default.
;   LORENTZIAN - if set, fit a lorentzian model function.
;   MOFFAT - if set, fit a Moffat model function.
;
;   MEASURE_ERRORS - synonym for ERRORS, for consistency with built-in
;                    IDL fitting routines.
;
;   NEGATIVE - if set, and ESTIMATES is not provided, then MPFIT2DPEAK
;              will assume that a negative peak is present -- a
;              valley.  Specifying this keyword is not normally
;              required, since MPFIT2DPEAK can determine this
;              automatically.
;
;   NFREE - the number of free parameters in the fit.  This includes
;           parameters which are not FIXED and not TIED, but it does
;           include parameters which are pegged at LIMITS.
;
;   PERROR - upon return, the 1-sigma uncertainties of the parameter
;            values A.  These values are only meaningful if the ERRORS
;            or WEIGHTS keywords are specified properly.
;
;            If the fit is unweighted (i.e. no errors were given, or
;            the weights were uniformly set to unity), then PERROR
;            will probably not represent the true parameter
;            uncertainties.  
;
;            *If* you can assume that the true reduced chi-squared
;            value is unity -- meaning that the fit is implicitly
;            assumed to be of good quality -- then the estimated
;            parameter uncertainties can be computed by scaling PERROR
;            by the measured chi-squared value.
;
;              DOF     = N_ELEMENTS(Z) - N_ELEMENTS(A)   ; deg of freedom
;              PCERROR = PERROR * SQRT(BESTNORM / DOF)   ; scaled uncertainties
;
;   QUIET - if set then diagnostic fitting messages are suppressed.
;           Default: QUIET=1 (i.e., no diagnostics)
;
;   SIGMA - synonym for PERROR (1-sigma parameter uncertainties), for
;           compatibility with GAUSSFIT.  Do not confuse this with the
;           Gaussian "sigma" width parameter.
;
;   TILT - if set, then the major and minor axes of the peak profile
;          are allowed to rotate with respect to the image axes.
;          Parameter A[6] will be set to the clockwise rotation angle
;          of the A[2] axis in radians.
;
;   WEIGHTS - Array of weights to be used in calculating the
;             chi-squared value.  If WEIGHTS is specified then the ERR
;             parameter is ignored.  The chi-squared value is computed
;             as follows:
;
;                CHISQ = TOTAL( (Z-MYFUNCT(X,Y,P))^2 * ABS(WEIGHTS) )
;
;             Here are common values of WEIGHTS:
;
;                1D/ERR^2 - Normal weighting (ERR is the measurement error)
;                1D/Y     - Poisson weighting (counting statistics)
;                1D       - Unweighted
;
;             The ERROR keyword takes precedence over any WEIGHTS
;             keyword values.  If no ERROR or WEIGHTS are given, then
;             the fit is unweighted.
;
;
; EXAMPLE:
;
; ; Construct a sample gaussian surface in range [-5,5] centered at [2,-3]
;   x = findgen(100)*0.1 - 5. & y = x
;   xx = x # (y*0 + 1)
;   yy = (x*0 + 1) # y
;   rr = sqrt((xx-2.)^2 + (yy+3.)^2)
;
; ; Gaussian surface with sigma=0.5, peak value of 3, noise with sigma=0.2
;   z = 3.*exp(-(rr/0.5)^2) + randomn(seed,100,100)*.2
;
; ; Fit gaussian parameters A
;   zfit = mpfit2dpeak(z, a, x, y)
;
; REFERENCES:
;
;   MINPACK-1, Jorge More', available from netlib (www.netlib.org).
;   "Optimization Software Guide," Jorge More' and Stephen Wright, 
;     SIAM, *Frontiers in Applied Mathematics*, Number 14.
;
; MODIFICATION HISTORY:
;
;   New algorithm for estimating starting values, CM, 31 Oct 1999
;   Documented, 02 Nov 1999
;   Small documentation fixes, 02 Nov 1999
;   Documented PERROR for unweighted fits, 03 Nov 1999, CM
;   Copying permission terms have been liberalized, 26 Mar 2000, CM
;   Small cosmetic changes, 21 Sep 2000, CM
;   Corrected bug introduced by cosmetic changes, 11 Oct 2000, CM :-)
;   Added POSITIVE keyword, 17 Nov 2000, CM
;   Removed TILT in common, in favor of FUNCTARGS approach, 23 Nov
;     2000, CM
;   Added SYMMETRIC keyword, documentation for TILT, and an example,
;     24 Nov 2000, CM
;   Changed SYMMETRIC to CIRCULAR, 17 Dec 2000, CM
;   Really change SYMMETRIC to CIRCULAR!, 13 Sep 2002, CM
;   Add error messages for SYMMETRIC and CIRCLE, 08 Nov 2002, CM
;   Make more consistent with comparable IDL routines, 30 Jun 2003, CM
;   Defend against users supplying strangely dimensioned X and Y, 29
;     Jun 2005, CM
;   Convert to IDL 5 array syntax (!), 16 Jul 2006, CM
;   Move STRICTARR compile option inside each function/procedure, 9 Oct 2006
;   Add COMPATIBILITY section, CM, 13 Dec 2007
;   Clarify documentation regarding what happens when ESTIMATES is not
;     set, CM, 14 Dec 2008
;
;  $Id: mpfit2dpeak.pro,v 1.10 2008/12/14 20:05:44 craigm Exp $
;-
; Copyright (C) 1997-2000, 2002, 2003, 2005, 2006, 2007, 2008 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; Compute the "u" value = (x/a)^2 + (y/b)^2 with optional rotation
function mpfit2dpeak_u, x, y, p, tilt=tilt, symmetric=sym
  COMPILE_OPT strictarr
  widx  = abs(p[2]) > 1e-20 & widy  = abs(p[3]) > 1e-20 
  if keyword_set(sym) then widy = widx
  xp    = x-p[4]            & yp    = y-p[5]
  theta = p[6]
  if keyword_set(tilt) AND theta NE 0 then begin
      c  = cos(theta) & s  = sin(theta)
      return, ( (xp * (c/widx) - yp * (s/widx))^2 + $
                (xp * (s/widy) + yp * (c/widy))^2 )
  endif else begin
      return, (xp/widx)^2 + (yp/widy)^2
  endelse

end

; Gaussian Function
function mpfit2dpeak_gauss, x, y, p, tilt=tilt, symmetric=sym, _extra=extra
  COMPILE_OPT strictarr
  sz = size(x)
  if sz[sz[0]+1] EQ 5 then smax = 26D else smax = 13.

  u = mpfit2dpeak_u(x, y, p, tilt=keyword_set(tilt), symmetric=keyword_set(sym))
  mask = u LT (smax^2)  ;; Prevents floating underflow
  return, p[0] + p[1] * mask * exp(-0.5 * u * mask)
end

; Lorentzian Function
function mpfit2dpeak_lorentz, x, y, p, tilt=tilt, symmetric=sym, _extra=extra
  COMPILE_OPT strictarr
  u = mpfit2dpeak_u(x, y, p, tilt=keyword_set(tilt), symmetric=keyword_set(sym))
  return, p[0] + p[1] / (u + 1)
end

; Moffat Function
function mpfit2dpeak_moffat, x, y, p, tilt=tilt, symmetric=sym, _extra=extra
  COMPILE_OPT strictarr
  u = mpfit2dpeak_u(x, y, p, tilt=keyword_set(tilt), symmetric=keyword_set(sym))
  return, p[0] + p[1] / (u + 1)^p[7]
end

function mpfit2dpeak, z, a, x, y, estimates=est, tilt=tilt, $
                      gaussian=gauss, lorentzian=lorentz, moffat=moffat, $
                      perror=perror, sigma=sigma, zerror=zerror, $
                      chisq=chisq, bestnorm=bestnorm, niter=iter, nfev=nfev, $
                      error=dz, weights=weights, measure_errors=dzm, $
                      nfree=nfree, dof=dof, $
                      negative=neg, parinfo=parinfo, $
                      circular=sym, circle=badcircle1, symmetric=badcircle2, $
                      errmsg=errmsg, status=status, $
                      query=query, quiet=quiet, _extra=extra

  COMPILE_OPT strictarr
  status = 0L
  errmsg = ''

  ;; Detect MPFIT and crash if it was not found
  catch, catcherror
  if catcherror NE 0 then begin
      MPFIT_NOTFOUND:
      catch, /cancel
      message, 'ERROR: the required functions MPFIT and MPFIT2DFUN ' + $
        'must be in your IDL path', /info
      return, !values.d_nan
  endif
  if mpfit(/query)      NE 1 then goto, MPFIT_NOTFOUND
  if mpfit2dfun(/query) NE 1 then goto, MPFIT_NOTFOUND
  catch, /cancel
  if keyword_set(query) then return, 1

  if keyword_set(badcircle1) OR keyword_set(badcircle2) then $
    message, 'ERROR: do not use the CIRCLE or SYMMETRIC keywords.  ' +$
    'Use CIRCULAR instead.'

  ;; Reject too few data
  if n_elements(z) LT 8 then begin
      message, 'ERROR: array must have at least eight elements', /info
      return, !values.d_nan
  endif

  sz = size(z)
  if sz[0] LT 2 then begin
      message, 'ERROR: array must be 2-dimensional', /info
      return, !values.d_nan
  endif
  nx = sz[1]
  ny = sz[2]
  
  ;; Fill in the X and Y values if needed -- note clever promotion to
  ;;                                         double if needed
  if n_elements(x) EQ 0 then x = findgen(nx)*(z[0]*0+1)
  if n_elements(y) EQ 0 then y = findgen(ny)*(z[0]*0+1)
  if n_elements(x) LT nx then begin
      message, 'ERROR: X array was not large enough', /info
      return, !values.d_nan
  endif
  if n_elements(y) LT ny then begin
      message, 'ERROR: Y array was not large enough', /info
      return, !values.d_nan
  endif

  ;; Make 2D arrays of X and Y values -- if the user hasn't done it
  if n_elements(x) NE n_elements(z) then   xx = x[*] # (y[*]*0 + 1)   else xx = x
  if n_elements(y) NE n_elements(z) then   yy = (x[*]*0 + 1) # y[*]   else yy = y

  ;; Compute the weighting factors to use
  if (n_elements(dz) EQ 0 AND n_elements(weights) EQ 0 AND $
      n_elements(dzm) EQ 0) then begin
      weights = z*0+1        ;; Unweighted by default
  endif else if n_elements(dz) GT 0 then begin
      weights = dz * 0   ;; Avoid division by zero
      wh = where(dz NE 0, ct)
      if ct GT 0 then weights[wh] = 1./dz[wh]^2
  endif else if n_elements(dzm) GT 0 then begin
      weights = dzm * 0   ;; Avoid division by zero
      wh = where(dzm NE 0, ct)
      if ct GT 0 then weights[wh] = 1./dzm[wh]^2
  endif

  if n_elements(est) EQ 0 then begin
      ;; Here is the secret - the width is estimated based on the volume
      ;; above/below the average.  Thus, as the signal becomes more
      ;; noisy the width automatically broadens as it should.

      maxx = max(x, min=minx) & maxy = max(y, min=miny)
      maxz = max(z, whmax)    & minz = min(z, whmin)
      nx = n_elements(x)
      dx = 0.5 * [x[1]-x[0], x[2:*] - x, x[nx-1] - x[nx-2]]
      ny = n_elements(y)
      dy = 0.5 * [y[1]-y[0], y[2:*] - y, y[ny-1] - y[ny-2]]
      ;; Compute cell areas
      da = dx # dy

      totvol = total(da*z)               ;; Total volume under curve
      av = totvol/(total(dx)*total(dy))  ;; Average height

      ;; Compute the spread in values above and below average... we
      ;; take the narrowest one as the one with the peak
      wh   = where(z GE av, ct1)
      sdx1 = total(xx[wh]^2)/ct1 - (total(xx[wh])/ct1)^2
      sdy1 = total(yy[wh]^2)/ct1 - (total(yy[wh])/ct1)^2
      wh   = where(z LE av, ct2)
      sdx2 = total(xx[wh]^2)/ct2 - (total(xx[wh])/ct2)^2
      sdy2 = total(yy[wh]^2)/ct2 - (total(yy[wh])/ct2)^2
      wh   = 0  ;; conserve memory

      if keyword_set(pos) then goto, POS_PEAK
      if keyword_set(neg) then goto, NEG_PEAK

      ;; Compute volume above/below average
      if (sdx1 LT sdx2 AND sdy1 LT sdy2) then begin 
          ;; Positive peak
          POS_PEAK:
          centx = xx[whmax]
          centy = yy[whmax]
          peakz = maxz - av
      endif else if (sdx1 GT sdx2 AND sdy1 GT sdy2) then begin 
          ;; Negative peak
          NEG_PEAK:
          centx = xx[whmin]
          centy = yy[whmin]
          peakz = minz - av
      endif else begin
          ;; Ambiguous case
          if abs(maxz - av) GT (minz - av) then goto, POS_PEAK $
          else                                  goto, NEG_PEAK
      endelse
      peakvol = totvol - total(da*(z<av))
      width   = sqrt(peakvol / (6*abs(peakz)))

      est = [av, peakz, width, width, centx, centy, 0, 1]
      guess = 1
  endif

  ;; Check the number of parameter estimates
  if n_elements(quiet) EQ 0 then quiet=1

  np = 7
  ;; Parameter checking for individual function types
  if keyword_set(moffat) then begin               ;; MOFFAT
      fun = 'mpfit2dpeak_moffat'
      np = 8
  endif else if keyword_set(lorentz) then begin  ;; LORENTZIAN
      fun = 'mpfit2dpeak_lorentz'
  endif else begin                               ;; GAUSSIAN
      fun = 'mpfit2dpeak_gauss'
  endelse
  if n_elements(est) LT np then begin
      message, 'ERROR: parameter ESTIMATES must have at least '+strtrim(np,2)+$
        ' elements', /info
      return, !values.d_nan
  endif
  p0 = replicate(est[0]*0, np > n_elements(est))
  p0[0] = est

  ;; Function call
  fargs = {tilt: keyword_set(tilt), symmetric: keyword_set(sym)}
  a = mpfit2dfun(fun, xx, yy, z, 0, p0[0:np-1], weights=weights, $
                 bestnorm=bestnorm, nfev=nfev, status=status, $
                 parinfo=parinfo, perror=perror, niter=iter, yfit=yfit, $
                 quiet=quiet, errmsg=errmsg, nfree=nfree, dof=dof, $
                 functargs=fargs, _EXTRA=extra)

  ;; Print error message if there is one.
  if NOT keyword_set(quiet) AND errmsg NE '' then $
    message, errmsg, /info

  ;; Make sure the parameters are sane
  if status NE 0 then begin
      ;; Width is positive
      a[2] = abs(a[2])
      a[3] = abs(a[3])
      if keyword_set(sym) then a[3] = a[2]
      ;; Make sure that theta is in the range [0,pi]
      a[6] = ((a[6] MOD !dpi) + 2*!dpi) MOD !dpi
      a = a[0:np-1]

      if n_elements(perror)   GT 0 then sigma = perror
      if n_elements(bestnorm) GT 0 then chisq = bestnorm

      if n_elements(yfit) EQ nx*ny then begin
          yfit = reform(yfit, nx, ny, /overwrite)
      endif

      zerror = a[0]*0
      if n_elements(dof) GT 0 AND dof[0] GT 0 then begin
          zerror[0] = sqrt( total( (z-yfit)^2 ) / dof[0] )
      endif

      return, yfit
  endif

  return, !values.d_nan
end

;+
; NAME:
;   MPFITELLIPSE
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;   UPDATED VERSIONs can be found on my WEB PAGE: 
;      http://cow.physics.wisc.edu/~craigm/idl/idl.html
;
; PURPOSE:
;   Approximate fit to points forming an ellipse
;
; MAJOR TOPICS:
;   Curve and Surface Fitting
;
; CALLING SEQUENCE:
;   parms = MPFITELLIPSE(X, Y, start_parms, [/TILT, WEIGHTS=wts, ...])
;
; DESCRIPTION:
;
;   MPFITELLIPSE fits a closed elliptical or circular curve to a two
;   dimensional set of data points.  The user specifies the X and Y
;   positions of the points, and an optional set of weights.  The
;   ellipse may also be tilted at an arbitrary angle.
;
;   IMPORTANT NOTE: this fitting program performs simple ellipse
;   fitting.  It will not work well for ellipse data with high
;   eccentricity.  More robust answers can usually be obtained with
;   "orthogonal distance regression."  (See FORTRAN package ODRPACK on
;   netlib.org for more information).
;
;   The best fitting ellipse parameters are returned from by
;   MPFITELLIPSE as a vector, whose values are:
;
;      P[0]   Ellipse semi axis 1
;      P[1]   Ellipse semi axis 2   ( = P[0] if CIRCLE keyword set)
;      P[2]   Ellipse center - x value
;      P[3]   Ellipse center - y value
;      P[4]   Ellipse rotation angle (radians) if TILT keyword set
;
;   If the TILT keyword is set, then the P[0] is meant to be the
;   semi-major axis, and P[1] is the semi-minor axis, and P[4]
;   represents the tilt of the semi-major axis with respect to the X
;   axis.  If the TILT keyword is not set, the P[0] and P[1] represent
;   the ellipse semi-axes in the X and Y directions, respectively.
;   The returned semi-axis lengths should always be positive.
;
;   The user may specify an initial set of trial parameters, but by
;   default MPFITELLIPSE will estimate the parameters automatically.
;
;   Users should be aware that in the presence of large amounts of
;   noise, namely when the measurement error becomes significant
;   compared to the ellipse axis length, then the estimated parameters
;   become unreliable.  Generally speaking the computed axes will
;   overestimate the true axes.  For example when (SIGMA_R/R) becomes
;   0.5, the radius of the ellipse is overestimated by about 40%.
;
;   This unreliability is also pronounced if the ellipse has high
;   eccentricity, as noted above.
;
;   Users can weight their data as they see appropriate.  However, the
;   following prescription for the weighting may serve as a good
;   starting point, and appeared to produce results comparable to the
;   typical chi-squared value.
;
;     WEIGHTS = 0.75/(SIGMA_X^2 + SIGMA_Y^2)
;
;   where SIGMA_X and SIGMA_Y are the measurement error vectors in the
;   X and Y directions respectively.  However, this has not been
;   robustly tested, and it should be pointed out that this weighting
;   may only be appropriate for a set of points whose measurement
;   errors are comparable.  If a more robust estimation of the
;   parameter values is needed, the so-called orthogonal distance
;   regression package should be used (ODRPACK, available in FORTRAN
;   at www.netlib.org).
;
; INPUTS:
;
;   X - measured X positions of the points in the ellipse.
;   Y - measured Y positions of the points in the ellipse.
;
;   START_PARAMS - an array of starting values for the ellipse
;                  parameters, as described above.  This parameter is
;                  optional; if not specified by the user, then the
;                  ellipse parameters are estimated automatically from
;                  the properties of the data.
;
; RETURNS:
;
;   Returns the best fitting model ellipse parameters.  Returned
;   values are undefined if STATUS indicates an error condition.
;
; KEYWORDS:
;
;   ** NOTE ** Additional keywords such as PARINFO, BESTNORM, and
;              STATUS are accepted by MPFITELLIPSE but not documented
;              here.  Please see the documentation for MPFIT for the
;              description of these advanced options.
;
;   CIRCULAR - if set, then the curve is assumed to be a circle
;              instead of ellipse.  When set, the parameters P[0] and
;              P[1] will be identical and the TILT keyword will have
;              no effect.
;
;   PERROR - upon return, the 1-sigma uncertainties of the returned
;            ellipse parameter values.  These values are only
;            meaningful if the WEIGHTS keyword is specified properly.
;
;            If the fit is unweighted (i.e. no errors were given, or
;            the weights were uniformly set to unity), then PERROR
;            will probably not represent the true parameter
;            uncertainties.
;
;            If STATUS indicates an error condition, then PERROR is
;            undefined.
;
;   QUIET - if set then diagnostic fitting messages are suppressed.
;           Default: QUIET=1 (i.e., no diagnostics]
;
;   STATUS - an integer status code is returned.  All values greater
;            than zero can represent success (however STATUS EQ 5 may
;            indicate failure to converge).  Please see MPFIT for
;            the definitions of status codes.
;
;   TILT - if set, then the major and minor axes of the ellipse
;          are allowed to rotate with respect to the data axes.
;          Parameter P[4] will be set to the clockwise rotation angle
;          of the P[0] axis in radians, as measured from the +X axis.
;          P[4] should be in the range 0 to !dpi.
;
;   WEIGHTS - Array of weights to be used in calculating the
;             chi-squared value.  The chi-squared value is computed
;             as follows:
;
;                CHISQ = TOTAL( (Z-MYFUNCT(X,Y,P))^2 * ABS(WEIGHTS)^2 )
;
;             Users may wish to follow the guidelines for WEIGHTS
;             described above.
;
;
; EXAMPLE:
;
; ; Construct a set of points on an ellipse, with some noise
;   ph0 = 2*!pi*randomu(seed,50)
;   x =  50. + 32.*cos(ph0) + 4.0*randomn(seed, 50)
;   y = -75. + 65.*sin(ph0) + 0.1*randomn(seed, 50)
;
; ; Compute weights function
;   weights = 0.75/(4.0^2 + 0.1^2)
;
; ; Fit ellipse and plot result
;   p = mpfitellipse(x, y)
;   phi = dindgen(101)*2D*!dpi/100
;   plot, x, y, psym=1
;   oplot, p[2]+p[0]*cos(phi), p[3]+p[1]*sin(phi), color='ff'xl
;
; ; Fit ellipse and plot result - WITH TILT
;   p = mpfitellipse(x, y, /tilt)
;   phi = dindgen(101)*2D*!dpi/100
;   ; New parameter P[4] gives tilt of ellipse w.r.t. coordinate axes
;   ; We must rotate a standard ellipse to this new orientation
;   xm = p[2] + p[0]*cos(phi)*cos(p[4]) + p[1]*sin(phi)*sin(p[4])
;   ym = p[3] - p[0]*cos(phi)*sin(p[4]) + p[1]*sin(phi)*cos(p[4])
;
;   plot, x, y, psym=1
;   oplot, xm, ym, color='ff'xl
;
; REFERENCES:
;
;   MINPACK-1, Jorge More', available from netlib (www.netlib.org).
;   "Optimization Software Guide," Jorge More' and Stephen Wright, 
;     SIAM, *Frontiers in Applied Mathematics*, Number 14.
;
; MODIFICATION HISTORY:
;
;   Ported from MPFIT2DPEAK, 17 Dec 2000, CM
;   More documentation, 11 Jan 2001, CM
;   Example corrected, 18 Nov 2001, CM
;   Change CIRCLE keyword to the correct CIRCULAR keyword, 13 Sep
;      2002, CM
;   Add error messages for SYMMETRIC and CIRCLE, 08 Nov 2002, CM
;   Found small error in computation of _EVAL (when CIRCULAR) was set;
;      sanity check when CIRCULAR is set, 21 Jan 2003, CM
;   Convert to IDL 5 array syntax (!), 16 Jul 2006, CM
;   Move STRICTARR compile option inside each function/procedure, 9
;     Oct 2006
;   Add disclaimer about the suitability of this program for fitting
;     ellipses, 17 Sep 2007, CM
;   Clarify documentation of TILT angle; make sure output contains
;    semi-major axis first, followed by semi-minor; make sure that
;    semi-axes are always positive (and can handle negative inputs)
;      17 Sep 2007, CM
;   Output tilt angle is now in range 0 to !DPI, 20 Sep 2007, CM
;   Some documentation clarifications, including to remove reference
;     to the "ERR" keyword, which does not exist, 17 Jan 2008, CM
;   Swapping of P[0] and P[1] only occurs if /TILT is set, 06 Nov
;     2009, CM
;   Document an example of how to plot a tilted ellipse, 09 Nov 2009, CM
;   Check for MPFIT error conditions and return immediately, 23 Jan 2010, CM
;
;  $Id: mpfitellipse.pro,v 1.14 2010/01/25 03:38:03 craigm Exp $
;-
; Copyright (C) 1997-2000,2002,2003,2007,2008,2009,2010 Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-
; Compute the "u" value = (x/a)^2 + (y/b)^2 with optional rotation
function mpfitellipse_u, x, y, p, tilt=tilt, circle=circle
  COMPILE_OPT strictarr
  widx  = abs(p[0]) > 1e-20 & widy  = abs(p[1]) > 1e-20 
  if keyword_set(circle) then widy  = widx
  xp    = x-p[2]            & yp    = y-p[3]
  theta = p[4]

  if keyword_set(tilt) AND theta NE 0 then begin
      c  = cos(theta) & s  = sin(theta)
      return, ( (xp * (c/widx) - yp * (s/widx))^2 + $
                (xp * (s/widy) + yp * (c/widy))^2 )
  endif else begin
      return, (xp/widx)^2 + (yp/widy)^2
  endelse

end

; This is the call-back function for MPFIT.  It evaluates the
; function, subtracts the data, and returns the residuals.
function mpfitellipse_eval, p, tilt=tilt, circle=circle, _EXTRA=extra

  COMPILE_OPT strictarr
  common mpfitellipse_common, xy, wc

  tilt = keyword_set(tilt) 
  circle = keyword_set(circle)
  u2 = mpfitellipse_u(xy[*,0], xy[*,1], p, tilt=tilt, circle=circle) - 1.

  if n_elements(wc) GT 0 then begin
      if circle then u2 = sqrt(abs(p[0]*p[0]*wc))*u2 $
      else           u2 = sqrt(abs(p[0]*p[1]*wc))*u2 
  endif

  return, u2
end

function mpfitellipse, x, y, p0, WEIGHTS=wts, $