r2rs-stats 0.1.1

use crate::sexprec::{SEXP, SEXPREC, SEXPTYPE};
use ::libc;
extern "C" {
    /* nil = NULL */
    /* symbols */
    /* lists of dotted pairs */
    /* closures */
    /* environments */
    /* promises: [un]evaluated closure arguments */
    /* language constructs (special lists) */
    /* special forms */
    /* builtin non-special forms */
    /* "scalar" string type (internal only)*/
    /* logical vectors */
    /* 11 and 12 were factors and ordered factors in the 1990s */
    /* integer vectors */
    /* real variables */
    /* complex variables */
    /* string vectors */
    /* dot-dot-dot object */
    /* make "any" args work.
    Used in specifying types for symbol
    registration to mean anything is okay  */
    /* generic vectors */
    /* expressions vectors */
    /* byte code */
    /* external pointer */
    /* weak reference */
    /* raw bytes */
    /* S4, non-vector */
    /* used for detecting PROTECT issues in memory.c */
    /* fresh node created in new page */
    /* node released by GC */
    /* Closure or Builtin or Special */
    /* NOT YET */
    /* These are also used with the write barrier on, in attrib.c and util.c */
    #[no_mangle]
    fn sqrt(_: libc::c_double) -> libc::c_double;
    /*
     *  R : A Computer Language for Statistical Data Analysis
     *  Copyright (C) 1998-2005   The R Core Team
     *
     *  This header file is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU Lesser General Public License as published by
     *  the Free Software Foundation; either version 2.1 of the License, or
     *  (at your option) any later version.
     *
     *  This file is part of R. R is distributed under the terms of the
     *  GNU General Public License, either Version 2, June 1991 or Version 3,
     *  June 2007. See doc/COPYRIGHTS for details of the copyright status of R.
     *
     *  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 Lesser General Public License for more details.
     *
     *  You should have received a copy of the GNU Lesser General Public License
     *  along with this program; if not, a copy is available at
     *  https://www.R-project.org/Licenses/
     */
    /* Included by R.h: API */
    #[no_mangle]
    fn error(_: *const libc::c_char, _: ...) -> !;
    #[no_mangle]
    fn isReal(s: SEXP) -> Rboolean;
    /* Vector Access Functions */
    #[no_mangle]
    fn LENGTH(x: SEXP) -> libc::c_int;
    #[no_mangle]
    fn REAL(x: SEXP) -> *mut libc::c_double;
    #[no_mangle]
    fn coerceVector(_: SEXP, _: SEXPTYPE) -> SEXP;
    #[no_mangle]
    fn duplicate(_: SEXP) -> SEXP;
    #[no_mangle]
    fn isInteger(_: SEXP) -> Rboolean;
    #[no_mangle]
    fn protect(_: SEXP) -> SEXP;
    #[no_mangle]
    fn unprotect(_: libc::c_int);
    #[no_mangle]
    fn dcgettext(
        __domainname: *const libc::c_char,
        __msgid: *const libc::c_char,
        __category: libc::c_int,
    ) -> *mut libc::c_char;
}
/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2000, 2001 The R Core Team.
 *
 *  This header file is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU Lesser General Public License as published by
 *  the Free Software Foundation; either version 2.1 of the License, or
 *  (at your option) any later version.
 *
 *  This file is part of R. R is distributed under the terms of the
 *  GNU General Public License, either Version 2, June 1991 or Version 3,
 *  June 2007. See doc/COPYRIGHTS for details of the copyright status of R.
 *
 *  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 Lesser General Public License for more details.
 *
 *  You should have received a copy of the GNU Lesser General Public License
 *  along with this program; if not, a copy is available at
 *  https://www.R-project.org/Licenses/
 */
/* Included by R.h: API */
pub type Rboolean = libc::c_uint;
pub const TRUE: Rboolean = 1;
pub const FALSE: Rboolean = 0;
/*, MAYBE */
/* Fundamental Data Types:  These are largely Lisp
 * influenced structures, with the exception of LGLSXP,
 * INTSXP, REALSXP, CPLXSXP and STRSXP which are the
 * element types for S-like data objects.
 *
 *   --> TypeTable[] in ../main/util.c for  typeof()
 */
/* UUID identifying the internals version -- packages using compiled
code should be re-installed when this changes */
/*  These exact numeric values are seldom used, but they are, e.g., in
 *  ../main/subassign.c, and they are serialized.
*/
/* NOT YET using enum:
 *  1) The SEXPREC struct below has 'SEXPTYPE type : 5'
 * (making FUNSXP and CLOSXP equivalent in there),
 * giving (-Wall only ?) warnings all over the place
 * 2) Many switch(type) { case ... } statements need a final `default:'
 * added in order to avoid warnings like [e.g. l.170 of ../main/util.c]
 *   "enumeration value `FUNSXP' not handled in switch"
 */
/*  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2010 The R Foundation
 *  Copyright (C) 2016 The R Core Team
 *
 *  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, a copy is available at
 *  https://www.R-project.org/Licenses/
 */
/* To be "exported" (as part of R's C API): */
/* *
 * Modify the slopes  m_k := s'(x_k) using Fritsch & Carlson (1980)'s algorithm
 *
 * @param m  numeric vector of length n, the preliminary desired slopes s'(x_i), i = 1:n
 * @param S the divided differences (y_{i+1} - y_i) / (x_{i+1} - x_i);        i = 1:(n-1)
 * @param n  == length(m) == 1 + length(S)
 * @return m*: the modified m[]'s: Note that m[] is modified in place
 * @author Martin Maechler, Date: 19 Apr 2010
 */
#[no_mangle]
pub unsafe extern "C" fn monoFC_mod(
    mut m: *mut libc::c_double,
    mut S: *mut libc::c_double,
    mut n: libc::c_int,
) {
    if n < 2 as libc::c_int {
        error(dcgettext(
            b"stats\x00" as *const u8 as *const libc::c_char,
            b"n must be at least two\x00" as *const u8 as *const libc::c_char,
            5 as libc::c_int,
        ));
    }
    let mut k: libc::c_int = 0 as libc::c_int;
    while k < n - 1 as libc::c_int {
        /* modify both (m[k] & m[k+1]) if needed : */
        let mut Sk: libc::c_double = *S.offset(k as isize);
        let mut k1: libc::c_int = k + 1 as libc::c_int;
        if Sk == 0.0f64 {
            /* or |S| < eps ?? FIXME ?? */
            let ref mut fresh0 = *m.offset(k1 as isize);
            *fresh0 = 0.0f64;
            *m.offset(k as isize) = *fresh0
        } else {
            let mut alpha: libc::c_double = *m.offset(k as isize) / Sk;
            let mut beta: libc::c_double = *m.offset(k1 as isize) / Sk;
            let mut a2b3: libc::c_double = 0.;
            let mut ab23: libc::c_double = 0.;
            a2b3 = 2 as libc::c_int as libc::c_double * alpha + beta
                - 3 as libc::c_int as libc::c_double;
            if a2b3 > 0 as libc::c_int as libc::c_double
                && {
                    ab23 = alpha + 2 as libc::c_int as libc::c_double * beta
                        - 3 as libc::c_int as libc::c_double;
                    (ab23) > 0 as libc::c_int as libc::c_double
                }
                && alpha * (a2b3 + ab23) < a2b3 * a2b3
            {
                /* we are outside the monotonocity region ==> fix slopes */
                let mut tauS: libc::c_double =
                    3 as libc::c_int as libc::c_double * Sk / sqrt(alpha * alpha + beta * beta);
                *m.offset(k as isize) = tauS * alpha;
                *m.offset(k1 as isize) = tauS * beta
            }
        }
        k += 1
    }
    /* end for */
}
/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2001-2017 The R Core Team.
 *  Copyright (C) 2003-2016 The R Foundation
 *
 *  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, a copy is available at
 *  https://www.R-project.org/Licenses/
 */
/* monoSpl.c : */
#[no_mangle]
pub unsafe extern "C" fn monoFC_m(mut m: SEXP, mut Sx: SEXP) -> SEXP {
    let mut val: SEXP = 0 as *mut SEXPREC;
    let mut n: libc::c_int = LENGTH(m);
    if isInteger(m) as u64 != 0 {
        val = protect(coerceVector(m, 14 as libc::c_int as SEXPTYPE))
    } else {
        if isReal(m) as u64 == 0 {
            error(dcgettext(
                b"stats\x00" as *const u8 as *const libc::c_char,
                b"Argument m must be numeric\x00" as *const u8 as *const libc::c_char,
                5 as libc::c_int,
            ));
        }
        val = protect(duplicate(m))
    }
    if n < 2 as libc::c_int {
        error(dcgettext(
            b"stats\x00" as *const u8 as *const libc::c_char,
            b"length(m) must be at least two\x00" as *const u8 as *const libc::c_char,
            5 as libc::c_int,
        ));
    }
    if isReal(Sx) as u64 == 0 || LENGTH(Sx) != n - 1 as libc::c_int {
        error(dcgettext(
            b"stats\x00" as *const u8 as *const libc::c_char,
            b"Argument Sx must be numeric vector one shorter than m[]\x00" as *const u8
                as *const libc::c_char,
            5 as libc::c_int,
        ));
    }
    /* Fix up the slopes m[] := val[]: */
    monoFC_mod(REAL(val), REAL(Sx), n);
    unprotect(1 as libc::c_int);
    return val;
}