Fix off-by-one issue with finding chpl home, then ensure CHPL_HOME is set in environment.

use Exec;
use FileSystem;

config const testDir = "/Users/tvandoren/src/chapel/test/release/examples/programs";

config const testverbose = false;
config const printEnv = testverbose;

proc main() {
  const chplHome = getChplHome();
  setEnv("CHPL_HOME", chplHome);

  if printEnv {
    writeln("### Chapel Environment ###");
    const chplEnv = run("$CHPL_HOME/util/printchplenv");
    write(chplEnv);
    writeln("##########################");
    writeln();
  }

  forall test in findTests(testDir) {
    runTest(test);
  }
}

proc runTest(test) {
  writeln("testing: ", test);
}

iter findTests(testDir) {
  for filename in findfiles(testDir, recursive=true) {
    if isChapelFile(filename) {
      yield filename;
    }
  }
}

iter findTests(testDir, param tag: iterKind)
  where tag == iterKind.standalone
{
  forall filename in findfiles(testDir, recursive=true) {
    if isChapelFile(filename) {
      yield filename;
    }
  }
}

proc getChplHome() {
  const output = run("chpl --print-chpl-home");
  var chplHome: string;

  for i in 1..output.length {
    if output.substring(i) == "\t" {
      chplHome = output.substring(1..i-1);
      break;
    }
  }

  if testverbose then
    writeln("CHPL_HOME: ", chplHome);

  return chplHome;
}

proc isChapelFile(filename) {
  return ".chpl" == filename.substring(filename.length-4..);
}

use Exec;
use FileSystem;

config const testDir = "/Users/tvandoren/src/chapel/test/release/examples/programs";

config const testverbose = false;
config const printEnv = testverbose;

proc main() {
  const chplHome = getChplHome();

  if printEnv {
    writeln("### Chapel Environment ###");
    const chplEnv = run("$CHPL_HOME/util/printchplenv");
    write(chplEnv);
    writeln("##########################");
    writeln();
  }

  forall test in findTests(testDir) {
    runTest(test);
  }
}

proc runTest(test) {
  writeln("testing: ", test);
}

iter findTests(testDir) {
  for filename in findfiles(testDir, recursive=true) {
    if isChapelFile(filename) {
      yield filename;
    }
  }
}

iter findTests(testDir, param tag: iterKind)
  where tag == iterKind.standalone
{
  forall filename in findfiles(testDir, recursive=true) {
    if isChapelFile(filename) {
      yield filename;
    }
  }
}

proc getChplHome() {
  const output = run("chpl --print-chpl-home");
  var chplHome: string;

  for i in 1..output.length {
    if output.substring(i) == "\t" {
      chplHome = output.substring(1..i);
      break;
    }
  }

  if testverbose then
    writeln("CHPL_HOME: ", chplHome);

  return chplHome;
}

proc isChapelFile(filename) {
  return ".chpl" == filename.substring(filename.length-4..);
}


fix test for 32-bit testing

fix test for 32-bit testing

/* Pi computation using Chudnovsky's algortithm.

 * Copyright 2002, 2005 Hanhong Xue (macroxue at yahoo dot com)

 * Slightly modified 2005 by Torbjorn Granlund (tege at swox dot com) to allow
   more than 2G digits to be computed.

 * Translated into Chapel by Brad Chamberlain, 2009-2010

 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 * 1. Redistributions of source code must retain the above copyright notice,
 * this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright notice,
 * this list of conditions and the following disclaimer in the documentation
 * and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO
 * EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

use GMP, Time;

param A = 13591409,
      B = 545140134,
      C = 640320,
      D = 12;

param BITS_PER_DIGIT  = 3.32192809488736234787,
      DIGITS_PER_ITER = 14.1816474627254776555,
      DOUBLE_PREC     = 53;

config param HAVE_DIVEXACT_PREINV = false;

config param printTimings = true;

proc CHECK_MEMUSAGE {
  //  writeln("CHECK_MEM_USAGE not implemented yet");
}

////////////////////////////////////////////////////////////////////////////

// TODO:
// Can variables be moved in to tighter scopes?
// Can casts between ulong and long be avoided/minimized?
// Can writeln be used to wrap gmp_printf and the like?
// Would we want to overload operators on these types?
// Refactor timing code into a routine
// Implement memory checks
// Fix timings -- currently they're bogus in some cases
// Use classes rather than records for fac_t and/or sieve_t?

var t1, t2: mpf_t;

config param do_gcd_time = false;

config const   d: c_long = 100,
             _out: c_int = 1;

const terms   = (d/DIGITS_PER_ITER): c_long,
      percent = terms/100.0;

record fac_t {
  var num_facs: c_long;
  var sdom: domain(1);
  var fac, pow: [sdom] c_ulong;
};

record sieve_t {
  var fac, pow, nxt: c_long;
};

const sieve_size = max(3*5*23*29+1, terms*6): c_long;
var sievedom = {0: c_long..#(sieve_size/2)};
var sieve: [sievedom] sieve_t;

var ftmp, fmul: fac_t;

param INIT_FACS = 32;

var gcd_time: c_long;

var gcd, mgcd: mpz_t;

var depth: c_long = 1;
while ((1<<depth) < terms) do
  depth += 1;
depth += 1;

var stackdom1 = {0..#depth},
    stackdom2 = stackdom1;

var gstack: [stackdom1] mpz_t,
    fpstack, fgstack: [stackdom1] fac_t,
    pstack, qstack: [stackdom2] mpz_t;

var top: c_long = 0;

proc main() {
  writeln("#terms=", terms, ", depth=", depth);

  const start = getCurrentTime();
  write("sieve   ");

  build_sieve(sieve);

  const mid0 = getCurrentTime();
  if (printTimings) then
    writeln("time = ", mid0-start);
  else
    writeln();

  mpz_init(pstack);
  mpz_init(qstack);
  mpz_init(gstack);
  fac_init(fpstack);
  fac_init(fgstack);
  mpz_init(gcd);

  if HAVE_DIVEXACT_PREINV then
    mpz_init(mgcd);

  fac_init(ftmp);
  fac_init(fmul);

  /* begin binary splitting process */
  if (terms <= 0) {
    mpz_set_ui(p2,1);
    mpz_set_ui(q2,0);
    mpz_set_ui(g2,1);
  } else {
    bs(0, terms: c_ulong, 0, 0);
  }

  const mid1 = getCurrentTime();
  write("\nbs      ");
  if (printTimings) then
    writeln("time = ", mid1-mid0);
  else
    writeln();
  write("   gcd  ");
  if (printTimings) then
    writeln("time = ", gcd_time);
  else
    writeln();

  //writeln("misc    ");

  /* free some resources */
  sievedom.clear();

  if HAVE_DIVEXACT_PREINV then
    mpz_clear(mgcd);

  mpz_clear(gcd);
  fac_clear(ftmp);
  fac_clear(fmul);

  for i in 1..depth-1 {
    mpz_clear(pstack[i]);
    mpz_clear(qstack[i]);
    mpz_clear(gstack[i]);
    fac_clear(fpstack[i]);
    fac_clear(fgstack[i]);
  }

  mpz_clear(gstack[0]);
  fac_clear(fpstack[0]);
  fac_clear(fgstack[0]);

  stackdom1.clear();

  /* prepare to convert integers to floats */
  mpf_set_default_prec((d*BITS_PER_DIGIT+16): mp_bitcnt_t);

  /*
	  p*(C/D)*sqrt(C)
    pi = -----------------
	     (q+A*p)
  */

  const psize = mpz_sizeinbase(p1,10),
        qsize = mpz_sizeinbase(q1,10);

  mpz_addmul_ui(q1, p1, A);
  mpz_mul_ui(p1, p1, C/D);

  var pi, qi: mpf_t;

  mpf_init(pi);
  mpf_set_z(pi, p1);
  mpz_clear(p1);

  mpf_init(qi);
  mpf_set_z(qi, q1);
  mpz_clear(q1);

  stackdom2.clear();

  const mid2 = getCurrentTime();

  /* initialize temp float variables for sqrt & div */
  mpf_init(t1);
  mpf_init(t2);
  //mpf_set_prec_raw(t1, mpf_get_prec(pi));

  /* final step */
  write("div     ");
  my_div(qi, pi, qi);
  const mid3 = getCurrentTime();
  if (printTimings) then
    writeln("time = ", mid3-mid2);
  else
    writeln();

  write("sqrt    ");
  my_sqrt_ui(pi, C);
  const mid4 = getCurrentTime();
  if (printTimings) then
    writeln("time = ", mid4-mid3);
  else
    writeln();

  write("mul     ");
  mpf_mul(qi, qi, pi);
  const end = getCurrentTime();
  if (printTimings) then
    writeln("time = ", end - mid4);
  else
    writeln();

  if (printTimings) then
    writeln("total   time = ", end - start);

  writeln("   P size=", psize, " digits (", format("%f", psize:real/d), ")\n",
          "   Q size=", qsize, " digits (", format("%f", qsize:real/d), ")");

  /* output Pi and timing statistics */
  if (_out&1)  {
    writeln("pi(0,", terms, ")=");
    mpf_out_str(chpl_cstdout(), 10:c_int, (d+2):size_t, qi);
    writeln();
  }

  /* free float resources */
  mpf_clear(pi);
  mpf_clear(qi);

  mpf_clear(t1);
  mpf_clear(t2);
}

proc build_sieve(s: [] sieve_t) {
  const n = s.numElements*2,
        m = sqrt(n): c_long;

  s[1/2].fac = 1;
  s[1/2].pow = 1;

  for i in 3..n by 2 {
    if (s[i/2].fac == 0) {
      s[i/2].fac = i;
      s[i/2].pow = 1;
      if (i<=m) {
        for (j,k) in zip(i*i..n by i+i, i/2..) {
	  if (s[j/2].fac==0) {
	    s[j/2].fac = i;
	    if (s[k].fac == i) {
	      s[j/2].pow = s[k].pow + 1;
	      s[j/2].nxt = s[k].nxt;
	    } else {
	      s[j/2].pow = 1;
	      s[j/2].nxt = k;
	    }
	  }
	}
      }
    }
  }
}

proc my_sqrt_ui(ref r: mpf_t, x: c_ulong) {
  const prec0 = mpf_get_prec(r);

  if (prec0 <= DOUBLE_PREC) {
    mpf_set_d(r, sqrt(x));
    return;
  }

  var bits: c_ulong = 0,
      prec = prec0;
  while (prec > DOUBLE_PREC) {
    const bit = prec&1;
    prec = (prec+bit)/2;
    bits = bits*2+bit;
  }

  mpf_set_prec_raw(t1, DOUBLE_PREC);
  mpf_set_d(t1, 1/sqrt(x));

  while (prec < prec0) {
    prec *= 2;
    if (prec < prec0) {
      /* t1 = t1+t1*(1-x*t1*t1)/2; */
      mpf_set_prec_raw(t2, prec);
      mpf_mul(t2, t1, t1);         // half x half -> full
      mpf_mul_ui(t2, t2, x);
      mpf_ui_sub(t2, 1, t2);
      mpf_set_prec_raw(t2, prec/2);
      mpf_div_2exp(t2, t2, 1);
      mpf_mul(t2, t2, t1);         // half x half -> half
      mpf_set_prec_raw(t1, prec);
      mpf_add(t1, t1, t2);
    } else {
      prec = prec0;
      /* t2=x*t1, t1 = t2+t1*(x-t2*t2)/2; */
      mpf_set_prec_raw(t2, prec/2);
      mpf_mul_ui(t2, t1, x);
      mpf_mul(r, t2, t2);          // half x half -> full
      mpf_ui_sub(r, x, r);
      mpf_mul(t1, t1, r);          // half x half -> half
      mpf_div_2exp(t1, t1, 1);
      mpf_add(r, t1, t2);
      break;
    }
    prec -= (bits&1);
    bits /=2;
  }
}

// r = y/x   WARNING: r cannot be the same as y.
proc my_div(ref r: mpf_t, ref y: mpf_t, in x: mpf_t) {
  const prec0 = mpf_get_prec(r);

  if (prec0<=DOUBLE_PREC) {
    mpf_set_d(r, mpf_get_d(y)/mpf_get_d(x));
    return;
  }

  var bits: c_ulong = 0,
      prec = prec0;
  while (prec > DOUBLE_PREC) {
    const bit = prec&1;
    prec = (prec+bit)/2;
    bits = bits*2 + bit;
  }

  mpf_set_prec_raw(t1, DOUBLE_PREC);
  mpf_ui_div(t1, 1, x);

  while (prec < prec0) {
    prec *= 2;
    if (prec < prec0) {
      /* t1 = t1+t1*(1-x*t1); */
      mpf_set_prec_raw(t2, prec);
      mpf_mul(t2, x, t1);          // full x half -> full
      mpf_ui_sub(t2, 1, t2);
      mpf_set_prec_raw(t2, prec/2);
      mpf_mul(t2, t2, t1);         // half x half -> half
      mpf_set_prec_raw(t1, prec);
      mpf_add(t1, t1, t2);
    } else {
      prec = prec0;
      /* t2=y*t1, t1 = t2+t1*(y-x*t2); */
      mpf_set_prec_raw(t2, prec/2);
      mpf_mul(t2, t1, y);          // half x half -> half
      mpf_mul(r, x, t2);           // full x half -> full
      mpf_sub(r, y, r);
      mpf_mul(t1, t1, r);          // half x half -> half
      mpf_add(r, t1, t2);
      break;
    }
    prec -= (bits&1);
    bits /=2;
  }
}

proc fac_show(f: fac_t) {
  for i in 0..#f.num_facs do
    if (f.pow[i]==1) then
      write(f.fac[i], " ");
    else
      write(f.fac[i], "^", f.pow[i], " ");
  writeln();
}

proc fac_reset(ref f: fac_t) {
  f.num_facs = 0;
}

proc fac_init_size(ref f: fac_t, in s: c_long) {
  if (s<INIT_FACS) then
    s=INIT_FACS;

  f.sdom = {0..#s};

  fac_reset(f);
}

proc fac_init(ref f: fac_t) {
  fac_init_size(f, INIT_FACS);
}

proc fac_clear(ref f: fac_t) {
  f.sdom.clear();
}

proc fac_resize(ref f: fac_t, s: c_long)
{
  if (f.sdom.numIndices < s) {
    fac_clear(f);
    fac_init_size(f, s);
  }
}

// BLC: unfortunate -- original GMP took advantage of long/ulong conversions
proc fac_set_bp(ref f: fac_t, base: c_ulong, pow: c_long) {
  assert (base < max(c_long): c_ulong);
  fac_set_bp(f, base: c_long, pow: c_long);
}

// f = base^pow
proc fac_set_bp(ref f: fac_t, in base: c_long, pow: c_long) {
  assert(base < sieve_size);
  var i: c_long;
  base /= 2;
  while (base > 0) {
    f.fac[i] = (sieve[base].fac): c_ulong;
    f.pow[i] = (sieve[base].pow*pow): c_ulong;
    base = sieve[base].nxt;
    i += 1;
  }
  f.num_facs = i;
  assert(i<=f.sdom.numIndices);
}

// r = f*g
proc fac_mul2(ref r: fac_t, f: fac_t, g: fac_t) {

  var i, j, k: c_long;
  while (i<f.num_facs && j<g.num_facs) {
    if (f.fac[i] == g.fac[j]) {
      r.fac[k] = f.fac[i];
      r.pow[k] = f.pow[i] + g.pow[j];
      i += 1; j += 1;
    } else if (f.fac[i] < g.fac[j]) {
      r.fac[k] = f.fac[i];
      r.pow[k] = f.pow[i];
      i += 1;
    } else {
      r.fac[k] = g.fac[j];
      r.pow[k] = g.pow[j];
      j += 1;
    }
    k += 1;
  }
  while (i < f.num_facs) {
    r.fac[k] = f.fac[i];
    r.pow[k] = f.pow[i];
    i += 1;
    k += 1;
  }
  while (j < g.num_facs) {
    r.fac[k] = g.fac[j];
    r.pow[k] = g.pow[j];
    j += 1;
    k += 1;
  }
  r.num_facs = k;
  assert(k<=r.sdom.numIndices);
}

// f *= g
proc fac_mul(ref f: fac_t, g: fac_t) {
  fac_resize(fmul, f.num_facs + g.num_facs);
  fac_mul2(fmul, f, g);
  f <=> fmul;
}

// BLC: unfortunate -- original GMP took advantage of long/ulong conversions
proc fac_mul_bp(ref f: fac_t, base: c_ulong, pow: c_long) {
  assert (base < max(c_long): c_ulong);
  fac_mul_bp(f, base:c_long, pow);
}

// f *= base^pow
proc fac_mul_bp(ref f: fac_t, base: c_long, pow: c_long) {
  fac_set_bp(ftmp, base, pow);
  fac_mul(f, ftmp);
}

// remove factors of power 0
proc fac_compact(ref f: fac_t) {
  var j: c_long;
  for i in 0..#f.num_facs {
    if (f.pow[i]>0) {
      if (j<i) {
	f.fac[j] = f.fac[i];
	f.pow[j] = f.pow[i];
      }
      j += 1;
    }
  }
  f.num_facs = j;
}

// convert factorized form to number
proc bs_mul(ref r: mpz_t, a: c_long, b: c_long) {
  if (b-a <= 32) {
    mpz_set_ui(r, 1);
    for i in a..b-1 do
      for j in 0..fmul.pow[i]-1 do  // BLC: would like to use # here
	mpz_mul_ui(r, r, fmul.fac[i]);
  } else {
    var r2: mpz_t;
    mpz_init(r2);
    bs_mul(r2, a, (a+b)/2);
    bs_mul(r, (a+b)/2, b);
    mpz_mul(r, r, r2);
    mpz_clear(r2);
  }
}

//#if HAVE_DIVEXACT_PREINV
//void mpz_invert_mod_2exp (mpz_ptr, mpz_srcptr);
//void mpz_divexact_pre (mpz_ptr, mpz_srcptr, mpz_srcptr, mpz_srcptr);
//
//#endif

// f /= gcd(f,g), g /= gcd(f,g)
proc fac_remove_gcd(ref p: mpz_t, ref fp: fac_t, ref g: mpz_t, ref fg: fac_t) {
  var i, j, k: c_long;
  var c: c_ulong;
  fac_resize(fmul, min(fp.num_facs, fg.num_facs));
  while (i < fp.num_facs && j < fg.num_facs) {
    if (fp.fac[i] == fg.fac[j]) {
      c = min(fp.pow[i], fg.pow[j]);
      fp.pow[i] -= c;
      fg.pow[j] -= c;
      fmul.fac[k] = fp.fac[i];
      fmul.pow[k] = c;
      i += 1; j += 1; k += 1;
    } else if (fp.fac[i] < fg.fac[j]) {
      i += 1;
    } else {
      j += 1;
    }
  }
  fmul.num_facs = k;
  assert(k <= fmul.sdom.numIndices);

  if (fmul.num_facs) {
    bs_mul(gcd, 0, fmul.num_facs);
    if HAVE_DIVEXACT_PREINV {
      mpz_invert_mod_2exp (mgcd, gcd);
      mpz_divexact_pre (p, p, gcd, mgcd);
      mpz_divexact_pre (g, g, gcd, mgcd);
    } else {
      mpz_tdiv_q(p, p, gcd);
      mpz_tdiv_q(g, g, gcd);
    }
    fac_compact(fp);
    fac_compact(fg);
  }
}

proc p1  ref return  pstack[top];
proc q1  ref return  qstack[top];
proc g1  ref return  gstack[top];
proc fp1 ref return fpstack[top];
proc fg1 ref return fgstack[top];

proc p2  ref return  pstack[top+1];
proc q2  ref return  qstack[top+1];
proc g2  ref return  gstack[top+1];
proc fp2 ref return fpstack[top+1];
proc fg2 ref return fgstack[top+1];

//////////////////////////////////////////////////////////////////////
//////

var progress = 0.0;

/*
proc mpz_t.writeThis(f) {
  var outfile = f: file;
    gmp_fprintf(outfile._fp, "%Zd", this);
  if (outfile) then
}
*/

// binary splitting
proc bs(a: c_ulong, b: c_ulong, gflag: c_uint, level: c_long) {
  if (b-a==1) {
    /*
      g(b-1,b) = (6b-5)(2b-1)(6b-1)
      p(b-1,b) = b^3 * C^3 / 24
      q(b-1,b) = (-1)^b*g(b-1,b)*(A+Bb).
    */
    mpz_set_ui(p1, b);
    mpz_mul_ui(p1, p1, b);
    mpz_mul_ui(p1, p1, b);
    mpz_mul_ui(p1, p1, (C/24)*(C/24));
    mpz_mul_ui(p1, p1, C*24);

    mpz_set_ui(g1, 2*b-1);
    mpz_mul_ui(g1, g1, 6*b-1);
    mpz_mul_ui(g1, g1, 6*b-5);

    mpz_set_ui(q1, b);
    mpz_mul_ui(q1, q1, B);
    mpz_add_ui(q1, q1, A);
    mpz_mul   (q1, q1, g1);
    if (b%2) then
      mpz_neg(q1, q1);

    var i = b;
    while ((i&1)==0) do i>>=1;
    fac_set_bp(fp1, i, 3);    // b^3
    fac_mul_bp(fp1, 3*5*23*29, 3);
    fp1.pow[0]-=1;

    fac_set_bp(fg1, 2*b-1, 1);   // 2b-1
    fac_mul_bp(fg1, 6*b-1, 1);   // 6b-1
    fac_mul_bp(fg1, 6*b-5, 1);   // 6b-5

    if (b > (progress:c_ulong)) {
      write(".");
      progress += percent*2;
    }

  } else {
    /*
      p(a,b) = p(a,m) * p(m,b)
      g(a,b) = g(a,m) * g(m,b)
      q(a,b) = q(a,m) * p(m,b) + q(m,b) * g(a,m)
    */
    const mid = (a+(b-a)*0.5224): c_ulong;     // tuning parameter
    bs(a, mid, 1, level+1);

    top += 1;
    bs(mid, b, gflag, level+1);
    top -= 1;

    if (level == 0) then
      write("");

    const ccc = level == 0;

    if (ccc) then CHECK_MEMUSAGE;

    if (level>=4) {           // tuning parameter
      if do_gcd_time {
        const t = getCurrentTime();
        fac_remove_gcd(p2, fp2, g1, fg1);
        gcd_time += getCurrentTime() - t;
      } else {
        fac_remove_gcd(p2, fp2, g1, fg1);
      }
    }

    if (ccc) then CHECK_MEMUSAGE;
    mpz_mul(p1, p1, p2);

    if (ccc) then CHECK_MEMUSAGE;
    mpz_mul(q1, q1, p2);

    if (ccc) then CHECK_MEMUSAGE;
    mpz_mul(q2, q2, g1);

    if (ccc) then CHECK_MEMUSAGE;
    mpz_add(q1, q1, q2);

    if (ccc) then CHECK_MEMUSAGE;
    fac_mul(fp1, fp2);

    if (gflag) {
      mpz_mul(g1, g1, g2);
      fac_mul(fg1, fg2);
    }
  }

  if (_out&2) {
    write("p(", a, ",", b, ")=");
    fac_show(fp1);
    if (gflag) then
      write("g(", a, ",", b, ")=");
    fac_show(fg1);
  }
}

/* Pi computation using Chudnovsky's algortithm.

 * Copyright 2002, 2005 Hanhong Xue (macroxue at yahoo dot com)

 * Slightly modified 2005 by Torbjorn Granlund (tege at swox dot com) to allow
   more than 2G digits to be computed.

 * Translated into Chapel by Brad Chamberlain, 2009-2010

 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 * 1. Redistributions of source code must retain the above copyright notice,
 * this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright notice,
 * this list of conditions and the following disclaimer in the documentation
 * and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO
 * EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

use GMP, Time;

param A = 13591409,
      B = 545140134,
      C = 640320,
      D = 12;

param BITS_PER_DIGIT  = 3.32192809488736234787,
      DIGITS_PER_ITER = 14.1816474627254776555,
      DOUBLE_PREC     = 53;

config param HAVE_DIVEXACT_PREINV = false;

config param printTimings = true;

proc CHECK_MEMUSAGE {
  //  writeln("CHECK_MEM_USAGE not implemented yet");
}

////////////////////////////////////////////////////////////////////////////

// TODO:
// Can variables be moved in to tighter scopes?
// Can casts between ulong and long be avoided/minimized?
// Can writeln be used to wrap gmp_printf and the like?
// Would we want to overload operators on these types?
// Refactor timing code into a routine
// Implement memory checks
// Fix timings -- currently they're bogus in some cases
// Use classes rather than records for fac_t and/or sieve_t?

var t1, t2: mpf_t;

config param do_gcd_time = false;

config const   d: c_long = 100,
             _out: c_int = 1;

const terms   = (d/DIGITS_PER_ITER): c_long,
      percent = terms/100.0;

record fac_t {
  var num_facs: c_long;
  var sdom: domain(1, idxType=c_long);
  var fac, pow: [sdom] c_ulong;
};

record sieve_t {
  var fac, pow, nxt: c_long;
};

const sieve_size = max(3*5*23*29+1, terms*6): c_long;
var sievedom = {0: c_long..#(sieve_size/2)};
var sieve: [sievedom] sieve_t;

var ftmp, fmul: fac_t;

param INIT_FACS = 32;

var gcd_time: c_long;

var gcd, mgcd: mpz_t;

var depth: c_long = 1;
while ((1<<depth) < terms) do
  depth += 1;
depth += 1;

var stackdom1 = {0..#depth},
    stackdom2 = stackdom1;

var gstack: [stackdom1] mpz_t,
    fpstack, fgstack: [stackdom1] fac_t,
    pstack, qstack: [stackdom2] mpz_t;

var top: c_long = 0;

proc main() {
  writeln("#terms=", terms, ", depth=", depth);

  const start = getCurrentTime();
  write("sieve   ");

  build_sieve(sieve);

  const mid0 = getCurrentTime();
  if (printTimings) then
    writeln("time = ", mid0-start);
  else
    writeln();

  mpz_init(pstack);
  mpz_init(qstack);
  mpz_init(gstack);
  fac_init(fpstack);
  fac_init(fgstack);
  mpz_init(gcd);

  if HAVE_DIVEXACT_PREINV then
    mpz_init(mgcd);

  fac_init(ftmp);
  fac_init(fmul);

  /* begin binary splitting process */
  if (terms <= 0) {
    mpz_set_ui(p2,1);
    mpz_set_ui(q2,0);
    mpz_set_ui(g2,1);
  } else {
    bs(0, terms: c_ulong, 0, 0);
  }

  const mid1 = getCurrentTime();
  write("\nbs      ");
  if (printTimings) then
    writeln("time = ", mid1-mid0);
  else
    writeln();
  write("   gcd  ");
  if (printTimings) then
    writeln("time = ", gcd_time);
  else
    writeln();

  //writeln("misc    ");

  /* free some resources */
  sievedom.clear();

  if HAVE_DIVEXACT_PREINV then
    mpz_clear(mgcd);

  mpz_clear(gcd);
  fac_clear(ftmp);
  fac_clear(fmul);

  for i in 1..depth-1 {
    mpz_clear(pstack[i]);
    mpz_clear(qstack[i]);
    mpz_clear(gstack[i]);
    fac_clear(fpstack[i]);
    fac_clear(fgstack[i]);
  }

  mpz_clear(gstack[0]);
  fac_clear(fpstack[0]);
  fac_clear(fgstack[0]);

  stackdom1.clear();

  /* prepare to convert integers to floats */
  mpf_set_default_prec((d*BITS_PER_DIGIT+16): mp_bitcnt_t);

  /*
	  p*(C/D)*sqrt(C)
    pi = -----------------
	     (q+A*p)
  */

  const psize = mpz_sizeinbase(p1,10),
        qsize = mpz_sizeinbase(q1,10);

  mpz_addmul_ui(q1, p1, A);
  mpz_mul_ui(p1, p1, C/D);

  var pi, qi: mpf_t;

  mpf_init(pi);
  mpf_set_z(pi, p1);
  mpz_clear(p1);

  mpf_init(qi);
  mpf_set_z(qi, q1);
  mpz_clear(q1);

  stackdom2.clear();

  const mid2 = getCurrentTime();

  /* initialize temp float variables for sqrt & div */
  mpf_init(t1);
  mpf_init(t2);
  //mpf_set_prec_raw(t1, mpf_get_prec(pi));

  /* final step */
  write("div     ");
  my_div(qi, pi, qi);
  const mid3 = getCurrentTime();
  if (printTimings) then
    writeln("time = ", mid3-mid2);
  else
    writeln();

  write("sqrt    ");
  my_sqrt_ui(pi, C);
  const mid4 = getCurrentTime();
  if (printTimings) then
    writeln("time = ", mid4-mid3);
  else
    writeln();

  write("mul     ");
  mpf_mul(qi, qi, pi);
  const end = getCurrentTime();
  if (printTimings) then
    writeln("time = ", end - mid4);
  else
    writeln();

  if (printTimings) then
    writeln("total   time = ", end - start);

  writeln("   P size=", psize, " digits (", format("%f", psize:real/d), ")\n",
          "   Q size=", qsize, " digits (", format("%f", qsize:real/d), ")");

  /* output Pi and timing statistics */
  if (_out&1)  {
    writeln("pi(0,", terms, ")=");
    mpf_out_str(chpl_cstdout(), 10:c_int, (d+2):size_t, qi);
    writeln();
  }

  /* free float resources */
  mpf_clear(pi);
  mpf_clear(qi);

  mpf_clear(t1);
  mpf_clear(t2);
}

proc build_sieve(s: [] sieve_t) {
  const n = s.numElements*2,
        m = sqrt(n): c_long;

  s[1/2].fac = 1;
  s[1/2].pow = 1;

  for i in 3..n by 2 {
    if (s[i/2].fac == 0) {
      s[i/2].fac = i;
      s[i/2].pow = 1;
      if (i<=m) {
        for (j,k) in zip(i*i..n by i+i, i/2..) {
	  if (s[j/2].fac==0) {
	    s[j/2].fac = i;
	    if (s[k].fac == i) {
	      s[j/2].pow = s[k].pow + 1;
	      s[j/2].nxt = s[k].nxt;
	    } else {
	      s[j/2].pow = 1;
	      s[j/2].nxt = k;
	    }
	  }
	}
      }
    }
  }
}

proc my_sqrt_ui(ref r: mpf_t, x: c_ulong) {
  const prec0 = mpf_get_prec(r);

  if (prec0 <= DOUBLE_PREC) {
    mpf_set_d(r, sqrt(x));
    return;
  }

  var bits: c_ulong = 0,
      prec = prec0;
  while (prec > DOUBLE_PREC) {
    const bit = prec&1;
    prec = (prec+bit)/2;
    bits = bits*2+bit;
  }

  mpf_set_prec_raw(t1, DOUBLE_PREC);
  mpf_set_d(t1, 1/sqrt(x));

  while (prec < prec0) {
    prec *= 2;
    if (prec < prec0) {
      /* t1 = t1+t1*(1-x*t1*t1)/2; */
      mpf_set_prec_raw(t2, prec);
      mpf_mul(t2, t1, t1);         // half x half -> full
      mpf_mul_ui(t2, t2, x);
      mpf_ui_sub(t2, 1, t2);
      mpf_set_prec_raw(t2, prec/2);
      mpf_div_2exp(t2, t2, 1);
      mpf_mul(t2, t2, t1);         // half x half -> half
      mpf_set_prec_raw(t1, prec);
      mpf_add(t1, t1, t2);
    } else {
      prec = prec0;
      /* t2=x*t1, t1 = t2+t1*(x-t2*t2)/2; */
      mpf_set_prec_raw(t2, prec/2);
      mpf_mul_ui(t2, t1, x);
      mpf_mul(r, t2, t2);          // half x half -> full
      mpf_ui_sub(r, x, r);
      mpf_mul(t1, t1, r);          // half x half -> half
      mpf_div_2exp(t1, t1, 1);
      mpf_add(r, t1, t2);
      break;
    }
    prec -= (bits&1);
    bits /=2;
  }
}

// r = y/x   WARNING: r cannot be the same as y.
proc my_div(ref r: mpf_t, ref y: mpf_t, in x: mpf_t) {
  const prec0 = mpf_get_prec(r);

  if (prec0<=DOUBLE_PREC) {
    mpf_set_d(r, mpf_get_d(y)/mpf_get_d(x));
    return;
  }

  var bits: c_ulong = 0,
      prec = prec0;
  while (prec > DOUBLE_PREC) {
    const bit = prec&1;
    prec = (prec+bit)/2;
    bits = bits*2 + bit;
  }

  mpf_set_prec_raw(t1, DOUBLE_PREC);
  mpf_ui_div(t1, 1, x);

  while (prec < prec0) {
    prec *= 2;
    if (prec < prec0) {
      /* t1 = t1+t1*(1-x*t1); */
      mpf_set_prec_raw(t2, prec);
      mpf_mul(t2, x, t1);          // full x half -> full
      mpf_ui_sub(t2, 1, t2);
      mpf_set_prec_raw(t2, prec/2);
      mpf_mul(t2, t2, t1);         // half x half -> half
      mpf_set_prec_raw(t1, prec);
      mpf_add(t1, t1, t2);
    } else {
      prec = prec0;
      /* t2=y*t1, t1 = t2+t1*(y-x*t2); */
      mpf_set_prec_raw(t2, prec/2);
      mpf_mul(t2, t1, y);          // half x half -> half
      mpf_mul(r, x, t2);           // full x half -> full
      mpf_sub(r, y, r);
      mpf_mul(t1, t1, r);          // half x half -> half
      mpf_add(r, t1, t2);
      break;
    }
    prec -= (bits&1);
    bits /=2;
  }
}

proc fac_show(f: fac_t) {
  for i in 0..#f.num_facs do
    if (f.pow[i]==1) then
      write(f.fac[i], " ");
    else
      write(f.fac[i], "^", f.pow[i], " ");
  writeln();
}

proc fac_reset(ref f: fac_t) {
  f.num_facs = 0;
}

proc fac_init_size(ref f: fac_t, in s: c_long) {
  if (s<INIT_FACS) then
    s=INIT_FACS;

  f.sdom = {0..#s};

  fac_reset(f);
}

proc fac_init(ref f: fac_t) {
  fac_init_size(f, INIT_FACS);
}

proc fac_clear(ref f: fac_t) {
  f.sdom.clear();
}

proc fac_resize(ref f: fac_t, s: c_long)
{
  if (f.sdom.numIndices < s) {
    fac_clear(f);
    fac_init_size(f, s);
  }
}

// BLC: unfortunate -- original GMP took advantage of long/ulong conversions
proc fac_set_bp(ref f: fac_t, base: c_ulong, pow: c_long) {
  assert (base < max(c_long): c_ulong);
  fac_set_bp(f, base: c_long, pow: c_long);
}

// f = base^pow
proc fac_set_bp(ref f: fac_t, in base: c_long, pow: c_long) {
  assert(base < sieve_size);
  var i: c_long;
  base /= 2;
  while (base > 0) {
    f.fac[i] = (sieve[base].fac): c_ulong;
    f.pow[i] = (sieve[base].pow*pow): c_ulong;
    base = sieve[base].nxt;
    i += 1;
  }
  f.num_facs = i;
  assert(i<=f.sdom.numIndices);
}

// r = f*g
proc fac_mul2(ref r: fac_t, f: fac_t, g: fac_t) {

  var i, j, k: c_long;
  while (i<f.num_facs && j<g.num_facs) {
    if (f.fac[i] == g.fac[j]) {
      r.fac[k] = f.fac[i];
      r.pow[k] = f.pow[i] + g.pow[j];
      i += 1; j += 1;
    } else if (f.fac[i] < g.fac[j]) {
      r.fac[k] = f.fac[i];
      r.pow[k] = f.pow[i];
      i += 1;
    } else {
      r.fac[k] = g.fac[j];
      r.pow[k] = g.pow[j];
      j += 1;
    }
    k += 1;
  }
  while (i < f.num_facs) {
    r.fac[k] = f.fac[i];
    r.pow[k] = f.pow[i];
    i += 1;
    k += 1;
  }
  while (j < g.num_facs) {
    r.fac[k] = g.fac[j];
    r.pow[k] = g.pow[j];
    j += 1;
    k += 1;
  }
  r.num_facs = k;
  assert(k<=r.sdom.numIndices);
}

// f *= g
proc fac_mul(ref f: fac_t, g: fac_t) {
  fac_resize(fmul, f.num_facs + g.num_facs);
  fac_mul2(fmul, f, g);
  f <=> fmul;
}

// BLC: unfortunate -- original GMP took advantage of long/ulong conversions
proc fac_mul_bp(ref f: fac_t, base: c_ulong, pow: c_long) {
  assert (base < max(c_long): c_ulong);
  fac_mul_bp(f, base:c_long, pow);
}

// f *= base^pow
proc fac_mul_bp(ref f: fac_t, base: c_long, pow: c_long) {
  fac_set_bp(ftmp, base, pow);
  fac_mul(f, ftmp);
}

// remove factors of power 0
proc fac_compact(ref f: fac_t) {
  var j: c_long;
  for i in 0..#f.num_facs {
    if (f.pow[i]>0) {
      if (j<i) {
	f.fac[j] = f.fac[i];
	f.pow[j] = f.pow[i];
      }
      j += 1;
    }
  }
  f.num_facs = j;
}

// convert factorized form to number
proc bs_mul(ref r: mpz_t, a: c_long, b: c_long) {
  if (b-a <= 32) {
    mpz_set_ui(r, 1);
    for i in a..b-1 do
      for j in 0..fmul.pow[i]-1 do  // BLC: would like to use # here
	mpz_mul_ui(r, r, fmul.fac[i]);
  } else {
    var r2: mpz_t;
    mpz_init(r2);
    bs_mul(r2, a, (a+b)/2);
    bs_mul(r, (a+b)/2, b);
    mpz_mul(r, r, r2);
    mpz_clear(r2);
  }
}

//#if HAVE_DIVEXACT_PREINV
//void mpz_invert_mod_2exp (mpz_ptr, mpz_srcptr);
//void mpz_divexact_pre (mpz_ptr, mpz_srcptr, mpz_srcptr, mpz_srcptr);
//
//#endif

// f /= gcd(f,g), g /= gcd(f,g)
proc fac_remove_gcd(ref p: mpz_t, ref fp: fac_t, ref g: mpz_t, ref fg: fac_t) {
  var i, j, k: c_long;
  var c: c_ulong;
  fac_resize(fmul, min(fp.num_facs, fg.num_facs));
  while (i < fp.num_facs && j < fg.num_facs) {
    if (fp.fac[i] == fg.fac[j]) {
      c = min(fp.pow[i], fg.pow[j]);
      fp.pow[i] -= c;
      fg.pow[j] -= c;
      fmul.fac[k] = fp.fac[i];
      fmul.pow[k] = c;
      i += 1; j += 1; k += 1;
    } else if (fp.fac[i] < fg.fac[j]) {
      i += 1;
    } else {
      j += 1;
    }
  }
  fmul.num_facs = k;
  assert(k <= fmul.sdom.numIndices);

  if (fmul.num_facs) {
    bs_mul(gcd, 0, fmul.num_facs);
    if HAVE_DIVEXACT_PREINV {
      mpz_invert_mod_2exp (mgcd, gcd);
      mpz_divexact_pre (p, p, gcd, mgcd);
      mpz_divexact_pre (g, g, gcd, mgcd);
    } else {
      mpz_tdiv_q(p, p, gcd);
      mpz_tdiv_q(g, g, gcd);
    }
    fac_compact(fp);
    fac_compact(fg);
  }
}

proc p1  ref return  pstack[top];
proc q1  ref return  qstack[top];
proc g1  ref return  gstack[top];
proc fp1 ref return fpstack[top];
proc fg1 ref return fgstack[top];

proc p2  ref return  pstack[top+1];
proc q2  ref return  qstack[top+1];
proc g2  ref return  gstack[top+1];
proc fp2 ref return fpstack[top+1];
proc fg2 ref return fgstack[top+1];

//////////////////////////////////////////////////////////////////////
//////

var progress = 0.0;

/*
proc mpz_t.writeThis(f) {
  var outfile = f: file;
    gmp_fprintf(outfile._fp, "%Zd", this);
  if (outfile) then
}
*/

// binary splitting
proc bs(a: c_ulong, b: c_ulong, gflag: c_uint, level: c_long) {
  if (b-a==1) {
    /*
      g(b-1,b) = (6b-5)(2b-1)(6b-1)
      p(b-1,b) = b^3 * C^3 / 24
      q(b-1,b) = (-1)^b*g(b-1,b)*(A+Bb).
    */
    mpz_set_ui(p1, b);
    mpz_mul_ui(p1, p1, b);
    mpz_mul_ui(p1, p1, b);
    mpz_mul_ui(p1, p1, (C/24)*(C/24));
    mpz_mul_ui(p1, p1, C*24);

    mpz_set_ui(g1, 2*b-1);
    mpz_mul_ui(g1, g1, 6*b-1);
    mpz_mul_ui(g1, g1, 6*b-5);

    mpz_set_ui(q1, b);
    mpz_mul_ui(q1, q1, B);
    mpz_add_ui(q1, q1, A);
    mpz_mul   (q1, q1, g1);
    if (b%2) then
      mpz_neg(q1, q1);

    var i = b;
    while ((i&1)==0) do i>>=1;
    fac_set_bp(fp1, i, 3);    // b^3
    fac_mul_bp(fp1, 3*5*23*29, 3);
    fp1.pow[0]-=1;

    fac_set_bp(fg1, 2*b-1, 1);   // 2b-1
    fac_mul_bp(fg1, 6*b-1, 1);   // 6b-1
    fac_mul_bp(fg1, 6*b-5, 1);   // 6b-5

    if (b > (progress:c_ulong)) {
      write(".");
      progress += percent*2;
    }

  } else {
    /*
      p(a,b) = p(a,m) * p(m,b)
      g(a,b) = g(a,m) * g(m,b)
      q(a,b) = q(a,m) * p(m,b) + q(m,b) * g(a,m)
    */
    const mid = (a+(b-a)*0.5224): c_ulong;     // tuning parameter
    bs(a, mid, 1, level+1);

    top += 1;
    bs(mid, b, gflag, level+1);
    top -= 1;

    if (level == 0) then
      write("");

    const ccc = level == 0;

    if (ccc) then CHECK_MEMUSAGE;

    if (level>=4) {           // tuning parameter
      if do_gcd_time {
        const t = getCurrentTime();
        fac_remove_gcd(p2, fp2, g1, fg1);
        gcd_time += getCurrentTime() - t;
      } else {
        fac_remove_gcd(p2, fp2, g1, fg1);
      }
    }

    if (ccc) then CHECK_MEMUSAGE;
    mpz_mul(p1, p1, p2);

    if (ccc) then CHECK_MEMUSAGE;
    mpz_mul(q1, q1, p2);

    if (ccc) then CHECK_MEMUSAGE;
    mpz_mul(q2, q2, g1);

    if (ccc) then CHECK_MEMUSAGE;
    mpz_add(q1, q1, q2);

    if (ccc) then CHECK_MEMUSAGE;
    fac_mul(fp1, fp2);

    if (gflag) {
      mpz_mul(g1, g1, g2);
      fac_mul(fg1, fg2);
    }
  }

  if (_out&2) {
    write("p(", a, ",", b, ")=");
    fac_show(fp1);
    if (gflag) then
      write("g(", a, ",", b, ")=");
    fac_show(fg1);
  }
}


More documentation

More documentation

/*
Example usage of the FFTW module in Chapel. This particular file demonstrates the single-threaded version of
the code.

To compile this code :
   chpl testFFTW.chpl
If FFTW is not on your include/library paths, you can do
   chpl testFFTW.chpl -I$FFTW_DIR/include -L$FFTW_DIR/lib
where $FFTW_DIR points to your FFTW installation.

Note that you do not need to explicitly include the header or library files; the module uses an experimental
feature of the Chapel compiler to automatically include these.

The FFTW module uses the FFTW3 API, and currently just implements the basic interface.
We will assume that the reader is familiar with using FFTW; more
details are at http://www.fftw.org.

The code computes a series of 1,2 and 3D transforms, exercising the complex <-> complex, and real<->complex
transforms (both in and out of place). The output of the code should be a series of small numbers ( <= 10^-13);
see testFFTW.good for example values (it is possible that your values might differ).

The data for these tests is in arr{1,2,3}d.dat. The format of these files is documented below.
*/
use FFTW;

/* Utility function to print the maximum absolute deviation between values computed by this code,
   and "truth". The true values are computed using Mathematica v10 */
proc printcmp(x, y) {
  var err = max reduce abs(x-y);
  writeln(err);
}

/* This is main test code, parametrized on the number of dimensions ndim.
  fn is the file that contains the test data.
*/
proc runtest(param ndim : int, fn : string) {
  var dims : ndim*int(32);

  /* We define a number of different domains below, corresponding to complex input/output arrays,
     real (input) -> complex (output) out-of-place arrays, and real <-> complex in-place arrays.

     The domains are :
     * D : for complex <-> complex transforms. This domain is also used for the real array in
           a real->complex out-of-place transform.
     * cD : for the complex array in a real <-> complex out-of-place transform.
     * rD : for the real array in a real <-> complex in-place transform. This includes the padding needed
            by the in-place transform. D is a sub-domain of this, and can be used to extract the real array,
            without padding.
     * reD, imD : Utility domains that access the real/complex parts of the complex array in a real<->complex in-place transform.
  */
  var D : domain(ndim);
  var rD,cD,reD,imD : domain(ndim,int,true);

  /* Read in the arrays from the file below. A,B are the arrays that will be used in the FFTW calls,
     goodA and goodB store the true values.

     Note that goodA is all real, allowing us to reuse the same array for the real<->complex tests.

     The file format is as follows (all little-endian):
        [ndim] int32 : dimensions of the array
        [narr] real64 : the real components of A (imaginary components are all zero). narr = N_1*N_2*..*N_ndim (product of dimensions)
        [narr] complex128 : the components of B (stored as real-imaginary pairs).

        The arrays are all stored in C (row-major) order.
  */
  var A,B,goodA,goodB : [D] complex;
  {
    var f = open(fn,iomode.r).reader(kind=iokind.little);
    // Read in dimensions
    for ii in 1..ndim {
      f.read(dims(ii));
    }
    /* The code below sets the domain D. Note that the if statements are folded at compile
       time. This would be more compact with a select statement, but that isn't folded on compilation.
    */
    if (ndim == 1) {
      D = 0.. #dims(ndim);
    }
    if (ndim == 2) {
      D = {0.. #dims(1),0.. #dims(ndim)};
    }
    if (ndim == 3) {
      D = {0.. #dims(1),0.. #dims(2), 0.. #dims(ndim)};
    }

    // Read in the arrays
    for val in goodA {
      f.read(val.re);
      val.im = 0;
    }
    for val in goodB {
      f.read(val);
    }
    f.close();
    writeln("Data read...");
  }

  /* Now set the remaining domains. As above, the if statements are folded on compilation.

     The reader is referred to the FFTW documentation on the storage order for the in-place
     transforms (Sec 2.4 and 4.3.4).
  */
  if (ndim==1) {
    var ldim = dims(1)/2 + 1;
    // Domains for real FFT
    rD = 0.. #(2*ldim); // Padding to do in place transforms
    cD = 0.. #ldim;
    // Define domains to extract the real and imaginary parts for inplace transforms
    reD = rD[0..(2*ldim-1) by 2];
    imD = rD[1..(2*ldim-1) by 2];
  }
  if (ndim==2) {
    // Domains for real FFT
    var ldim = dims(2)/2+1;
    rD = {0.. #dims(1),0.. #(2*ldim)}; // Padding to do in place transforms
    cD = {0.. #dims(1),0.. #ldim};
    // Define domains to extract the real and imaginary parts for in place transforms
    reD = rD[..,0..(2*ldim-1) by 2];
    imD = rD[..,1..(2*ldim-1) by 2];
  }
  if (ndim==3) {
    // Domains for real FFT
    var ldim = dims(3)/2+1;
    rD = {0.. #dims(1),0.. #dims(2),0.. #(2*ldim)}; // Padding to do in place transforms
    cD = {0.. #dims(1),0.. #dims(2),0.. #ldim};
    // Define domains to extract the real and imaginary parts for in place transforms
    reD = rD[..,..,0..(2*ldim-1) by 2];
    imD = rD[..,..,1..(2*ldim-1) by 2];
  }

  // FFTW does not normalize inverse transform, so just compute the normalization constant.
  var norm = * reduce dims;

  /* We start the FFT tests below. The structure is the same :
      * Define plans for forward and reverse transforms.
      * Execute forward transform A -> B.
      * Compare with goodB.
      * Execute reverse transform B -> A and normalize.
      * Compare with goodA.
      * Cleanup plans
  */

  /* Complex <-> complex
  */
	var fwd = plan_dft(A, B, FFTW_FORWARD, FFTW_ESTIMATE);
	var rev = plan_dft(B, A, FFTW_BACKWARD, FFTW_ESTIMATE);
	// Test forward and reverse transform
	A = goodA;
	execute(fwd);
	printcmp(B,goodB);
	execute(rev);
	A /= norm;
	printcmp(A,goodA);
	destroy_plan(fwd);
	destroy_plan(rev);

	// Test in-place transforms
	fwd = plan_dft(A, A, FFTW_FORWARD, FFTW_ESTIMATE);
	rev = plan_dft(A, A, FFTW_BACKWARD, FFTW_ESTIMATE);
	A = goodA;
	// Test forward and reverse transform
	A = goodA;
	execute(fwd);
	printcmp(A,goodB);
	execute(rev);
	A /= norm; // FFTW does an unnormalized transform
	printcmp(A,goodA);
	destroy_plan(fwd);
	destroy_plan(rev);

  // Testing r2c and c2r
  var rA : [D] real(64); // No padding for an out-of place transform
  var cB : [cD] complex;
  fwd = plan_dft_r2c(rA,cB,FFTW_ESTIMATE);
  rev = plan_dft_c2r(cB,rA,FFTW_ESTIMATE);
  rA[D] = goodA.re;
  execute(fwd);
  printcmp(cB,goodB[cD]);
  execute(rev);
  rA /= norm;
  printcmp(rA[D],goodA.re);
  destroy_plan(fwd);
  destroy_plan(rev);
  // In place transform
  var rA2 : [rD] real(64);
  fwd = plan_dft_r2c(D,rA2,FFTW_ESTIMATE);
  rev = plan_dft_c2r(D,rA2,FFTW_ESTIMATE);
  rA2[D] = goodA.re;
  execute(fwd);
  printcmp(rA2[reD],goodB[cD].re);
  printcmp(rA2[imD],goodB[cD].im);
  execute(rev);
  rA2 /= norm;
  printcmp(rA2[D],goodA.re);
  destroy_plan(fwd);
  destroy_plan(rev);

}

proc testAllDims() {
  writeln("1D");
  runtest(1, "arr1d.dat");
  writeln("2D");
  runtest(2, "arr2d.dat");
  writeln("3D");
  runtest(3, "arr3d.dat");
}

proc main() {
  testAllDims();
  cleanup();
}

/*
Example usage of the FFTW module in Chapel. This particular file demonstrates the single-threaded version of
the code.

To compile this code :
   chpl testFFTW.chpl
If FFTW is not on your include/library paths, you can do
   chpl testFFTW.chpl -I$FFTW_DIR/include -L$FFTW_DIR/lib
where $FFTW_DIR points to your FFTW installation.

Note that you do not need to explicitly include the header or library files; the module uses an experimental
feature of the Chapel compiler to automatically include these.

The FFTW module uses the FFTW3 API, and currently just implements the basic interface.
We will assume that the reader is familiar with using FFTW; more
details are at http://www.fftw.org.

The code computes a series of 1,2 and 3D transforms, exercising the complex <-> complex, and real<->complex
transforms (both in and out of place). The output of the code should be a series of small numbers ( <= 10^-13);
see testFFTW.good for example values (it is possible that your values might differ).

The data for these tests is in arr{1,2,3}d.dat.
*/
use FFTW;

/* Utility function to print the maximum absolute deviation between values computed by this code,
   and "truth". The true values are computed using Mathematica v10 */
proc printcmp(x, y) {
  var err = max reduce abs(x-y);
  writeln(err);
}

proc runtest(param ndim : int, fn : string) {
  /* Read in the data and set up the domains appropriately */
  var dims : ndim*int(32);
  var D : domain(ndim);
  // Define ranges here
  var rD,cD,reD,imD : domain(ndim,int,true);
  var A,B,goodA,goodB : [D] complex;
  {
    var f = open(fn,iomode.r).reader(kind=iokind.little);
    for ii in 1..ndim {
      f.read(dims(ii));
    }
    // Note compiler does not automatically fold select on params
    if (ndim == 1) {
      D = 0.. #dims(ndim);
    }
    if (ndim == 2) {
      D = {0.. #dims(1),0.. #dims(ndim)};
    }
    if (ndim == 3) {
      D = {0.. #dims(1),0.. #dims(2), 0.. #dims(ndim)};
    }
    for val in goodA {
      f.read(val.re);
      val.im = 0;
    }
    for val in goodB {
      f.read(val);
    }
    f.close();
    writeln("Data read...");
  }
  // Set up domains based on dimension size
  if (ndim==1) {
    var ldim = dims(1)/2 + 1;
    // Domains for real FFT
    rD = 0.. #(2*ldim); // Padding to do in place transforms
    cD = 0.. #ldim;
    // Define domains to extract the real and imaginary parts for inplace transforms
    reD = rD[0..(2*ldim-1) by 2]; // Padding to do in place transforms
    imD = rD[1..(2*ldim-1) by 2]; // Padding to do in place transforms
  }
  if (ndim==2) {
    // Domains for real FFT
    var ldim = dims(2)/2+1;
    rD = {0.. #dims(1),0.. #(2*ldim)}; // Padding to do in place transforms
    cD = {0.. #dims(1),0.. #ldim};
    // Define domains to extract the real and imaginary parts for in place transforms
    reD = rD[..,0..(2*ldim-1) by 2]; // Padding to do in place transforms
    imD = rD[..,1..(2*ldim-1) by 2]; // Padding to do in place transforms
  }
  if (ndim==3) {
    // Domains for real FFT
    var ldim = dims(3)/2+1;
    rD = {0.. #dims(1),0.. #dims(2),0.. #(2*ldim)}; // Padding to do in place transforms
    cD = {0.. #dims(1),0.. #dims(2),0.. #ldim};
    // Define domains to extract the real and imaginary parts for in place transforms
    reD = rD[..,..,0..(2*ldim-1) by 2]; // Padding to do in place transforms
    imD = rD[..,..,1..(2*ldim-1) by 2]; // Padding to do in place transforms
  }

  // FFTW does not normalize inverse transform, set up norm
  var norm = * reduce dims;

	// FFT testing here
	var fwd = plan_dft(A, B, FFTW_FORWARD, FFTW_ESTIMATE);
	var rev = plan_dft(B, A, FFTW_BACKWARD, FFTW_ESTIMATE);
	// Test forward and reverse transform
	A = goodA;
	execute(fwd);
	printcmp(B,goodB);
	execute(rev);
	A /= norm;
	printcmp(A,goodA);
	destroy_plan(fwd);
	destroy_plan(rev);

	// Test in-place transforms
	fwd = plan_dft(A, A, FFTW_FORWARD, FFTW_ESTIMATE);
	rev = plan_dft(A, A, FFTW_BACKWARD, FFTW_ESTIMATE);
	A = goodA;
	// Test forward and reverse transform
	A = goodA;
	execute(fwd);
	printcmp(A,goodB);
	execute(rev);
	A /= norm; // FFTW does an unnormalized transform
	printcmp(A,goodA);
	destroy_plan(fwd);
	destroy_plan(rev);

  // Testing r2c and c2r
  var rA : [D] real(64); // No padding for an out-of place transform
  var cB : [cD] complex;
  fwd = plan_dft_r2c(rA,cB,FFTW_ESTIMATE);
  rev = plan_dft_c2r(cB,rA,FFTW_ESTIMATE);
  rA[D] = goodA.re;
  execute(fwd);
  printcmp(cB,goodB[cD]);
  execute(rev);
  rA /= norm;
  printcmp(rA[D],goodA.re);
  destroy_plan(fwd);
  destroy_plan(rev);
  // In place transform
  var rA2 : [rD] real(64);
  fwd = plan_dft_r2c(D,rA2,FFTW_ESTIMATE);
  rev = plan_dft_c2r(D,rA2,FFTW_ESTIMATE);
  rA2[D] = goodA.re;
  execute(fwd);
  printcmp(rA2[reD],goodB[cD].re);
  printcmp(rA2[imD],goodB[cD].im);
  execute(rev);
  rA2 /= norm;
  printcmp(rA2[D],goodA.re);
  destroy_plan(fwd);
  destroy_plan(rev);

}

proc testAllDims() {
  writeln("1D");
  runtest(1, "arr1d.dat");
  writeln("2D");
  runtest(2, "arr2d.dat");
  writeln("3D");
  runtest(3, "arr3d.dat");
}

proc main() {
  testAllDims();
  cleanup();
}


Sunday back to zero - resubmitting (intended change) of revision 14269 that was
rolled back in revision 14272. This is a simple change:

sunday (first element) in Day enumeration of time module is now set to zero so
it conforms with dayofweek int values coming in from C.

git-svn-id: 88467cb1fb04b8a755be7e1ee1026be4190196ef@14279 3a8e244f-b0f2-452b-bcba-4c88e055c3ca

enum TimeUnits { microseconds, milliseconds, seconds, minutes, hours };
enum Day { sunday=0, monday, tuesday, wednesday, thursday, friday, saturday };

// returns time elapsed since midnight
def getCurrentTime(unit: TimeUnits = TimeUnits.seconds)
  return _convert_microseconds(unit, __primitive("_now_time"));

// returns (year, month, day) as a tuple of 3 ints
def getCurrentDate()
  return (__primitive("_now_year")+1900,
          __primitive("_now_month")+1,
          __primitive("_now_day"));

def getCurrentDayOfWeek() {
    return __primitive("_now_dow"):Day;
}

record Timer {
  var time: _timervalue;
  var accumulated: real = 0.0;
  var running: bool = false;

  def initialize() {
    __primitive("_init_timer", time);
  }

  def clear() {
    accumulated = 0.0;
    running = false;
  }

  def start() {
    if !running {
      running = true;
      time = __primitive("_now_timer", time);
    } else {
      halt("start called on a timer that has not been stopped");
    }
  }

  def stop() {
    if running {
      var time2: _timervalue;
      time2 = __primitive("_now_timer", time2);
      accumulated += _diff_timer(time2, time);
      running = false;
    } else {
      halt("stop called on a timer that has not been started");
    }
  }

  def elapsed(unit: TimeUnits = TimeUnits.seconds) {
    if running {
      var time2: _timervalue;
      time2 = __primitive("_now_timer", time2);
      return _convert_microseconds(unit, accumulated + _diff_timer(time2, time));
    } else {
      return _convert_microseconds(unit, accumulated);
    }
  }
}

// returns diff of two timer values in microseconds
pragma "inline"
def _diff_timer(t1: _timervalue, t2: _timervalue) {
  var s1 = __primitive("_seconds_timer", t1);
  var s2 = __primitive("_seconds_timer", t2);
  var us1 = __primitive("_microseconds_timer", t1);
  var us2 = __primitive("_microseconds_timer", t2);
  return (s1*1.0e+6+us1)-(s2*1.0e+6+us2);
}

// converts microseconds to another unit
def _convert_microseconds(unit: TimeUnits, us: real) {
  select unit {
    when TimeUnits.microseconds do return us;
    when TimeUnits.milliseconds do return us / 1.0e+3;
    when TimeUnits.seconds do return us / 1.0e+6;
    when TimeUnits.minutes do return us / 60.0e+6;
    when TimeUnits.hours do return us / 3600.0e+6;
  }
  halt("internal error in module Time");
  // will never get here, but to avoid warnings:
  return -1.0;
}

pragma "inline" def sleep(t: uint) {
  __primitive("sleep", t);
}

enum TimeUnits { microseconds, milliseconds, seconds, minutes, hours };
enum Day { sunday, monday, tuesday, wednesday, thursday, friday, saturday };

// returns time elapsed since midnight
def getCurrentTime(unit: TimeUnits = TimeUnits.seconds)
  return _convert_microseconds(unit, __primitive("_now_time"));

// returns (year, month, day) as a tuple of 3 ints
def getCurrentDate()
  return (__primitive("_now_year")+1900,
          __primitive("_now_month")+1,
          __primitive("_now_day"));

def getCurrentDayOfWeek() {
    return (__primitive("_now_dow")+1):Day;
}

record Timer {
  var time: _timervalue;
  var accumulated: real = 0.0;
  var running: bool = false;

  def initialize() {
    __primitive("_init_timer", time);
  }

  def clear() {
    accumulated = 0.0;
    running = false;
  }

  def start() {
    if !running {
      running = true;
      time = __primitive("_now_timer", time);
    } else {
      halt("start called on a timer that has not been stopped");
    }
  }

  def stop() {
    if running {
      var time2: _timervalue;
      time2 = __primitive("_now_timer", time2);
      accumulated += _diff_timer(time2, time);
      running = false;
    } else {
      halt("stop called on a timer that has not been started");
    }
  }

  def elapsed(unit: TimeUnits = TimeUnits.seconds) {
    if running {
      var time2: _timervalue;
      time2 = __primitive("_now_timer", time2);
      return _convert_microseconds(unit, accumulated + _diff_timer(time2, time));
    } else {
      return _convert_microseconds(unit, accumulated);
    }
  }
}

// returns diff of two timer values in microseconds
pragma "inline"
def _diff_timer(t1: _timervalue, t2: _timervalue) {
  var s1 = __primitive("_seconds_timer", t1);
  var s2 = __primitive("_seconds_timer", t2);
  var us1 = __primitive("_microseconds_timer", t1);
  var us2 = __primitive("_microseconds_timer", t2);
  return (s1*1.0e+6+us1)-(s2*1.0e+6+us2);
}

// converts microseconds to another unit
def _convert_microseconds(unit: TimeUnits, us: real) {
  select unit {
    when TimeUnits.microseconds do return us;
    when TimeUnits.milliseconds do return us / 1.0e+3;
    when TimeUnits.seconds do return us / 1.0e+6;
    when TimeUnits.minutes do return us / 60.0e+6;
    when TimeUnits.hours do return us / 3600.0e+6;
  }
  halt("internal error in module Time");
  // will never get here, but to avoid warnings:
  return -1.0;
}

pragma "inline" def sleep(t: uint) {
  __primitive("sleep", t);
}