gdl-mpfit 1.85+2017.01.03-1 / usr / share / gnudatalanguage / mpfit / mpchilim.pro

;+
; 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.
;-

forward_function cephes_ndtri, cephes_igam, cephes_igamc, cephes_igami

;; 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