[R-pkg-devel] Solaris SPARC, Fortran, and logical errors?

[Avraham Adler]

Hello.

The Delaporte package works properly on all R-core platforms except
Solaris SPARC, where it  compiles properly but fails a number of its
tests [1]. Not having access to a SPARC testbed, I'm limited in what
kind of diagnostics I can do. One thing I have noticed is that a lot
of the failures occur when I am passing non-default logicals (like
lower tail or log). For example, the first failure at that link is
when "log = true" is supposed to be passed, but the SPARC answers are
the unlogged values. Of the 22 failed tests, 12 of them pass logicals.

I'll bring an example of how it is coded below, and if anyone
recognizes where SPARC specifically goes wrong, I'd appreciate. I
guess, if I absolutely had to, I could convert the logical to an
integer in C and pass the integer to Fortran which should work even
for SPARC, but I'd prefer not to if I could help it.

Thank you,

Avi

[1] https://cran.r-project.org/web/checks/check_results_Delaporte.html

*****Example Code*****

R code:

ddelap <- function(x, alpha, beta, lambda, log = FALSE){
  if(!is.double(x)) {storage.mode(x) <- 'double'}
  if(!is.double(alpha)) {storage.mode(alpha) <- 'double'}
  if(!is.double(beta)) {storage.mode(beta) <- 'double'}
  if(!is.double(lambda)) {storage.mode(lambda) <- 'double'}
  if(any(x > floor(x))) {
    warning("Non-integers passed to ddelap. These will have 0 probability.")
  }
  .Call(ddelap_C, x, alpha, beta, lambda, log)
}

C code:

void ddelap_f(double *x, int nx, double *a, int na, double *b, int nb,
double *l, int nl,
              int *lg, double *ret);

extern SEXP ddelap_C(SEXP x, SEXP alpha, SEXP beta, SEXP lambda, SEXP lg){
  const int nx = LENGTH(x);
  const int na = LENGTH(alpha);
  const int nb = LENGTH(beta);
  const int nl = LENGTH(lambda);
  SEXP ret;
  PROTECT(ret = allocVector(REALSXP, nx));
  ddelap_f(REAL(x), nx, REAL(alpha), na, REAL(beta), nb, REAL(lambda),
nl, LOGICAL(lg), REAL(ret));
  UNPROTECT(1);
  return(ret);
}

Fortran: (not posting ddelap_f_s as that doesn't handle the logging)

    subroutine ddelap_f(x, nx, a, na, b, nb, l, nl, lg, pmfv) bind(C,
name="ddelap_f")

    integer(kind = c_int), intent(in), value         :: nx, na, nb, nl
    ! Sizes
    real(kind = c_double), intent(in), dimension(nx) :: x
    ! Observations
    real(kind = c_double), intent(out), dimension(nx):: pmfv
    ! Result
    real(kind = c_double), intent(in)                :: a(na), b(nb),
l(nl)! Parameters
    logical(kind = c_bool), intent(in)               :: lg
    ! Log flag
    integer                                          :: i
    ! Integer

        !$omp parallel do default(shared) private(i)
        do i = 1, nx
            if (x(i) > floor(x(i))) then
                pmfv(i) = ZERO
            else
                pmfv(i) = ddelap_f_s(x(i), a(mod(i - 1, na) + 1), &
                                     b(mod(i - 1, nb) + 1), l(mod(i -
1, nl) + 1))
            end if
        end do
        !$omp end parallel do

        if (lg) then
            pmfv = log(pmfv)
        end if

    end subroutine ddelap_f