/*
 *  Mathlib : A C Library of Special Functions
 *  Copyright (C) 1998       Ross Ihaka
 *  Copyright (C) 2000--2005 The R Development Core Team
 *  based on AS 111 (C) 1977 Royal Statistical Society
 *  and   on AS 241 (C) 1988 Royal Statistical Society
 *
 *  Merge in to MAGRO:
 *  Copyright (C) 2010 Wataru Uda
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *
 *  SYNOPSIS
 *
 *      double qnorm5(NMATH_STATE *state, double p, double mu, double sigma,
 *                    int lower_tail, int log_p)
 *            {qnorm (..) is synonymous and preferred inside R}
 *
 *  DESCRIPTION
 *
 *      Compute the quantile function for the normal distribution.
 *
 *      For small to moderate probabilities, algorithm referenced
 *      below is used to obtain an initial approximation which is
 *      polished with a final Newton step.
 *
 *      For very large arguments, an algorithm of Wichura is used.
 *  
 *      For threading support, add a NMATH_STATE argument. (2010, Wataru Uda)
 *
 *  REFERENCE
 *
 *      Beasley, J. D. and S. G. Springer (1977).
 *      Algorithm AS 111: The percentage points of the normal distribution,
 *      Applied Statistics, 26, 118-121.
 *
 *      Wichura, M.J. (1988).
 *      Algorithm AS 241: The Percentage Points of the Normal Distribution.
 *      Applied Statistics, 37, 477-484.
 */
#include "nmath.h"

 double qnorm5(NMATH_STATE *state, double p, double mu, double sigma, int lower_tail, int log_p)
        {
            double p_, q, r, val;
			double _LEFT_, _RIGHT_;

            if (isnan(p) || isnan(mu) || isnan(sigma))
                return p + mu + sigma;

            //R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
            _LEFT_ = NEGINF;
            _RIGHT_ = POSINF;
            if (log_p != 0)
            {
                if (p > 0)
                    return NaN;
                if (p == 0) /* upper bound*/
                    return lower_tail != 0 ? _RIGHT_ : _LEFT_;
                if (p == NEGINF)
                    return lower_tail != 0 ? _LEFT_ : _RIGHT_;
            }
            else
            { /* !log_p */
                if (p < 0 || p > 1)
                    return NaN;
                if (p == 0)
                    return lower_tail != 0 ? _LEFT_ : _RIGHT_;
                if (p == 1)
                    return lower_tail != 0 ? _RIGHT_ : _LEFT_;
            }

            if (sigma < 0) return NaN;
            if (sigma == 0) return mu;

            //p_ = R_DT_qIv(p);/* real lower_tail prob. p */
            p_ = (log_p != 0 ? (lower_tail != 0 ? exp(p) : -expm1(p)) :
                //R_D_Lval(p));
                (lower_tail != 0 ? (p) : (0.5 - (p) + 0.5)));
            q = p_ - 0.5;

            /*-- use AS 241 --- */
            /* double ppnd16_(double *p, long *ifault)*/
            /*      ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3

                    Produces the normal deviate Z corresponding to a given lower
                    tail area of P; Z is accurate to about 1 part in 10**16.

                    (original fortran code used PARAMETER(..) for the coefficients
                     and provided hash codes for checking them...)
            */
            if (fabs(q) <= 0.425)
            {/* 0.075 <= p <= 0.925 */
                r = .180625 - q * q;
                val =
                    q * (((((((r * 2509.0809287301226727 +
                               33430.575583588128105) * r + 67265.770927008700853) * r +
                             45921.953931549871457) * r + 13731.693765509461125) * r +
                           1971.5909503065514427) * r + 133.14166789178437745) * r +
                         3.387132872796366608)
                    / (((((((r * 5226.495278852854561 +
                             28729.085735721942674) * r + 39307.89580009271061) * r +
                           21213.794301586595867) * r + 5394.1960214247511077) * r +
                         687.1870074920579083) * r + 42.313330701600911252) * r + 1.0);
            }
            else
            { /* closer than 0.075 from {0,1} boundary */

                /* r = min(p, 1-p) < 0.075 */
                if (q > 0)
                    //            r = R_DT_CIv(p);/* 1-p */
                    r = (log_p != 0 ? (lower_tail != 0 ? -expm1(p) : exp(p)) :
                        //                  R_D_Cval(p));
                          (lower_tail != 0 ? (0.5 - (p) + 0.5) : (p)));
                else
                    r = p_;/* = R_DT_Iv(p) ^=  p */

                r = sqrt(-((log_p != 0 &&
                             ((lower_tail != 0 && q <= 0) || (!(lower_tail != 0) && q > 0))) ?
                            p : /* else */ log(r)));
                /* r = sqrt(-log(r))  <==>  min(p, 1-p) = exp( - r^2 ) */


                if (r <= 5.0)
                { /* <==> min(p,1-p) >= exp(-25) ~= 1.3888e-11 */
                    r += -1.6;
                    val = (((((((r * 7.7454501427834140764e-4 +
                               .0227238449892691845833) * r + .24178072517745061177) *
                             r + 1.27045825245236838258) * r +
                            3.64784832476320460504) * r + 5.7694972214606914055) *
                          r + 4.6303378461565452959) * r +
                         1.42343711074968357734)
                        / (((((((r *
                                 1.05075007164441684324e-9 + 5.475938084995344946e-4) *
                                r + .0151986665636164571966) * r +
                               .14810397642748007459) * r + .68976733498510000455) *
                             r + 1.6763848301838038494) * r +
                            2.05319162663775882187) * r + 1.0);
                }
                else
                { /* very close to  0 or 1 */
                    r += -5.0;
                    val = (((((((r * 2.01033439929228813265e-7 +
                               2.71155556874348757815e-5) * r +
                              .0012426609473880784386) * r + .026532189526576123093) *
                            r + .29656057182850489123) * r +
                           1.7848265399172913358) * r + 5.4637849111641143699) *
                         r + 6.6579046435011037772)
                        / (((((((r *
                                 2.04426310338993978564e-15 + 1.4215117583164458887e-7) *
                                r + 1.8463183175100546818e-5) * r +
                               7.868691311456132591e-4) * r + .0148753612908506148525)
                             * r + .13692988092273580531) * r +
                            .59983220655588793769) * r + 1.0);
                }

                if (q < 0.0)
                    val = -val;
                /* return (q >= 0.)? r : -r ;*/
            }
            return mu + sigma * val;
        }

