~ubuntu-branches/debian/sid/libvcflib/sid

« back to all changes in this revision

Viewing changes to src/cdflib.cpp

Committer: Package Import Robot
Author(s): Andreas Tille
Date: 2016-09-16 15:52:29 UTC
Revision ID: package-import@ubuntu.com-20160916155229-24mxrntfylvsshsg

Tags: upstream-1.0.0~rc1+dfsg

Import upstream version 1.0.0~rc1+dfsg

files added:

.gitignore

.gitmodules

.travis.yml

1KG_Index

1KG_Index/1KG_IDs.txt

1KG_Index/1kG_ethnic_index.py

1KG_Index/README

LICENSE

Makefile

Makefile.old

README.md

bin/plotBfst.R

bin/plotHapLrt.R

bin/plotHaplotypes.R

bin/plotPfst.R

bin/plotSmoothed.R

bin/plotWCfst.R

bin/plotXPEHH.R

examples

examples/612.bFst_SatApr12_12_29_17.png

examples/612.counts_FriApr11_13_16_42.png

examples/612.nocounts.smoothed_TueApr15_13_25_53.png

examples/612.nocounts_FriApr11_13_16_38.png

examples/612.wcfst.txt_FriApr11_13_17_02.png

examples/example-ehh.png

examples/headCrest.haps.txt_ThuMay29_15_08_53.pdf

examples/headCrest.haps.txt_ThuMay29_15_08_53.png

examples/phasing-diff-res.png

examples/phasing-results.png

examples/scaffold612.d-stat.10kb.txt_abba-baba_WedOct29_10_17_10.png

examples/t.hapass.txt_TueJun24_11_52_08.png

examples/xp-phased.txt

examples/xp-phased.txt_TueApr29_13_20_47.png

examples/xp-unphased.txt

examples/xp-unphased.txt_TueApr29_13_20_58.png

examples/xpehh_WedApr23_11_30_10.png

fastahack

filevercmp

fsom

intervaltree

logos

logos/websiteLogo.pdf

logos/websiteLogo.png

multichoose

samples

samples/sample.vcf

samples/scaffold612.phased.vcf

samples/scaffold612.vcf

smithwaterman

src/BedReader.h

src/LD.cpp

src/Variant.cpp

src/Variant.h

src/abba-baba.cpp

src/bFst.cpp

src/cdflib.cpp

src/cdflib.hpp

src/convert.h

src/dumpContigsFromHeader.cpp

src/genotypeSummary.cpp

src/gl-XPEHH.cpp

src/gpatInfo.hpp

src/hapLrt.cpp

src/iHS.cpp

src/join.h

src/meltEHH.cpp

src/mt19937ar.h

src/normalize-iHS.cpp

src/pFst.cpp

src/pdflib.cpp

src/pdflib.hpp

src/permuteGPAT++.cpp

src/permuteGPATsmoother.cpp

src/permuteRegions.cpp

src/permuteSmooth.cpp

src/plotHaps.cpp

src/popStats.cpp

src/rnglib.cpp

src/rnglib.hpp

src/segmentFst.cpp

src/segmentIhs.cpp

src/sequenceDiversity.cpp

src/smoother.cpp

src/split.cpp

src/split.h

src/splitUniqStarts.cpp

src/ssw.c

src/ssw.h

src/ssw_cpp.cpp

src/ssw_cpp.h

src/var.cpp

src/var.hpp

src/vcf2dag.cpp

src/vcf2fasta.cpp

src/vcf2tsv.cpp

src/vcfToHap.cpp

src/vcfaddinfo.cpp

src/vcfafpath.cpp

src/vcfallelicprimitives.cpp

src/vcfaltcount.cpp

src/vcfannotate.cpp

src/vcfannotategenotypes.cpp

src/vcfbreakmulti.cpp

src/vcfcat.cpp

src/vcfcheck.cpp

src/vcfclassify.cpp

src/vcfcleancomplex.cpp

src/vcfcombine.cpp

src/vcfcommonsamples.cpp

src/vcfcountalleles.cpp

src/vcfcreatemulti.cpp

src/vcfdistance.cpp

src/vcfecho.cpp

src/vcfentropy.cpp

src/vcfevenregions.cpp

src/vcffilter.cpp

src/vcffixup.cpp

src/vcfflatten.cpp

src/vcfgeno2alleles.cpp

src/vcfgeno2haplo.cpp

src/vcfgenosamplenames.cpp

src/vcfgenosummarize.cpp

src/vcfgenotypecompare.cpp

src/vcfgenotypes.cpp

src/vcfglbound.cpp

src/vcfglxgt.cpp

src/vcfhetcount.cpp

src/vcfhethomratio.cpp

src/vcfindex.cpp

src/vcfinfo2qual.cpp

src/vcfinfosummarize.cpp

src/vcfintersect.cpp

src/vcfkeepgeno.cpp

src/vcfkeepinfo.cpp

src/vcfkeepsamples.cpp

src/vcfleftalign.cpp

src/vcflength.cpp

src/vcfnumalt.cpp

src/vcfoverlay.cpp

src/vcfparsealts.cpp

src/vcfprimers.cpp

src/vcfqual2info.cpp

src/vcfrandom.cpp

src/vcfrandomsample.cpp

src/vcfremap.cpp

src/vcfremoveaberrantgenotypes.cpp

src/vcfremovesamples.cpp

src/vcfroc.cpp

src/vcfsample2info.cpp

src/vcfsamplediff.cpp

src/vcfsamplenames.cpp

src/vcfsamplestats.cpp

src/vcfsitesummarize.cpp

src/vcfsom.cpp

src/vcfstats.cpp

src/vcfstreamsort.cpp

src/vcfuniq.cpp

src/vcfuniqalleles.cpp

src/wcFst.cpp

src/xpEHH.cpp

tabixpp

tests

tests/lib

tests/lib/Local

tests/lib/Local/vcflib

tests/lib/Local/vcflib/Test.pm

tests/vcfdistance.t

Show diffs side-by-side

added added

removed removed

src/cdflib.cpp

# include <cstdlib>

# include <iostream>

# include <iomanip>

# include <cmath>

# include <ctime>

# include <cstring>

using namespace std;

# include "cdflib.hpp"

//****************************************************************************80

double algdiv ( double *a, double *b )

//****************************************************************************80

// Purpose:

// ALGDIV computes ln ( Gamma ( B ) / Gamma ( A + B ) ) when 8 <= B.

// Discussion:

// In this algorithm, DEL(X) is the function defined by

// ln ( Gamma(X) ) = ( X - 0.5 ) * ln ( X ) - X + 0.5 * ln ( 2 * PI )

// + DEL(X).

// Parameters:

// Input, double *A, *B, define the arguments.

// Output, double ALGDIV, the value of ln(Gamma(B)/Gamma(A+B)).

{

static double algdiv;

static double c;

static double c0 = 0.833333333333333e-01;

static double c1 = -0.277777777760991e-02;

static double c2 = 0.793650666825390e-03;

static double c3 = -0.595202931351870e-03;

static double c4 = 0.837308034031215e-03;

static double c5 = -0.165322962780713e-02;

static double d;

static double h;

static double s11;

static double s3;

static double s5;

static double s7;

static double s9;

static double t;

static double T1;

static double u;

static double v;

static double w;

static double x;

static double x2;

if ( *b <= *a )

{

h = *b / *a;

c = 1.0e0 / ( 1.0e0 + h );

x = h / ( 1.0e0 + h );

d = *a + ( *b - 0.5e0 );

}

else

{

h = *a / *b;

c = h / ( 1.0e0 + h );

x = 1.0e0 / ( 1.0e0 + h );

d = *b + ( *a - 0.5e0 );

}

// SET SN = (1 - X**N)/(1 - X)

x2 = x * x;

s3 = 1.0e0 + ( x + x2 );

s5 = 1.0e0 + ( x + x2 * s3 );

s7 = 1.0e0 + ( x + x2 * s5 );

s9 = 1.0e0 + ( x + x2 * s7 );

s11 = 1.0e0 + ( x + x2 * s9 );

// SET W = DEL(B) - DEL(A + B)

t = pow ( 1.0e0 / *b, 2.0 );

w = (((( c5 * s11 * t

+ c4 * s9 ) * t

+ c3 * s7 ) * t

+ c2 * s5 ) * t

+ c1 * s3 ) * t

+ c0;

w *= ( c / *b );

// Combine the results.

T1 = *a / *b;

u = d * alnrel ( &T1 );

100

v = *a * ( log ( *b ) - 1.0e0 );

101

102

if ( v < u )

103

{

104

algdiv = w - v - u;

105

}

106

else

107

{

108

algdiv = w - u - v;

109

}

110

return algdiv;

111

}

112

//****************************************************************************80

113

114

double alnrel ( double *a )

115

116

//****************************************************************************80

117

118

// Purpose:

119

120

// ALNREL evaluates the function ln ( 1 + A ).

121

122

// Modified:

123

124

// 17 November 2006

125

126

// Reference:

127

128

// Armido DiDinato, Alfred Morris,

129

// Algorithm 708:

130

// Significant Digit Computation of the Incomplete Beta Function Ratios,

131

// ACM Transactions on Mathematical Software,

132

// Volume 18, 1993, pages 360-373.

133

134

// Parameters:

135

136

// Input, double *A, the argument.

137

138

// Output, double ALNREL, the value of ln ( 1 + A ).

139

140

{

141

double alnrel;

142

static double p1 = -0.129418923021993e+01;

143

static double p2 = 0.405303492862024e+00;

144

static double p3 = -0.178874546012214e-01;

145

static double q1 = -0.162752256355323e+01;

146

static double q2 = 0.747811014037616e+00;

147

static double q3 = -0.845104217945565e-01;

148

double t;

149

double t2;

150

double w;

151

double x;

152

153

if ( fabs ( *a ) <= 0.375e0 )

154

{

155

t = *a / ( *a + 2.0e0 );

156

t2 = t * t;

157

w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)

158

/ (((q3*t2+q2)*t2+q1)*t2+1.0e0);

159

alnrel = 2.0e0 * t * w;

160

}

161

else

162

{

163

x = 1.0e0 + *a;

164

alnrel = log ( x );

165

}

166

return alnrel;

167

}

168

//****************************************************************************80

169

170

double apser ( double *a, double *b, double *x, double *eps )

171

172

//****************************************************************************80

173

174

// Purpose:

175

176

// APSER computes the incomplete beta ratio I(SUB(1-X))(B,A).

177

178

// Discussion:

179

180

// APSER is used only for cases where

181

182

// A <= min ( EPS, EPS * B ),

183

// B * X <= 1, and

184

// X <= 0.5.

185

186

// Parameters:

187

188

// Input, double *A, *B, *X, the parameters of teh

189

// incomplete beta ratio.

190

191

// Input, double *EPS, a tolerance.

192

193

// Output, double APSER, the computed value of the

194

// incomplete beta ratio.

195

196

{

197

static double g = 0.577215664901533e0;

198

static double apser,aj,bx,c,j,s,t,tol;

199

200

bx = *b**x;

201

t = *x-bx;

202

if(*b**eps > 2.e-2) goto S10;

203

c = log(*x)+psi(b)+g+t;

204

goto S20;

205

S10:

206

c = log(bx)+g+t;

207

S20:

208

tol = 5.0e0**eps*fabs(c);

209

j = 1.0e0;

210

s = 0.0e0;

211

S30:

212

j = j + 1.0e0;

213

t = t * (*x-bx/j);

214

aj = t/j;

215

s = s + aj;

216

if(fabs(aj) > tol) goto S30;

217

apser = -(*a*(c+s));

218

return apser;

219

}

220

//****************************************************************************80

221

222

double bcorr ( double *a0, double *b0 )

223

224

//****************************************************************************80

225

226

// Purpose:

227

228

// BCORR evaluates DEL(A0) + DEL(B0) - DEL(A0 + B0).

229

230

// Discussion:

231

232

// The function DEL(A) is a remainder term that is used in the expression:

233

234

// ln ( Gamma ( A ) ) = ( A - 0.5 ) * ln ( A )

235

// - A + 0.5 * ln ( 2 * PI ) + DEL ( A ),

236

237

// or, in other words, DEL ( A ) is defined as:

238

239

// DEL ( A ) = ln ( Gamma ( A ) ) - ( A - 0.5 ) * ln ( A )

240

// + A + 0.5 * ln ( 2 * PI ).

241

242

// Parameters:

243

244

// Input, double *A0, *B0, the arguments.

245

// It is assumed that 8 <= A0 and 8 <= B0.

246

247

// Output, double *BCORR, the value of the function.

248

249

{

250

static double c0 = 0.833333333333333e-01;

251

static double c1 = -0.277777777760991e-02;

252

static double c2 = 0.793650666825390e-03;

253

static double c3 = -0.595202931351870e-03;

254

static double c4 = 0.837308034031215e-03;

255

static double c5 = -0.165322962780713e-02;

256

static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2;

257

258

a = fifdmin1 ( *a0, *b0 );

259

b = fifdmax1 ( *a0, *b0 );

260

h = a / b;

261

c = h / ( 1.0e0 + h );

262

x = 1.0e0 / ( 1.0e0 + h );

263

x2 = x * x;

264

265

// SET SN = (1 - X**N)/(1 - X)

266

267

s3 = 1.0e0 + ( x + x2 );

268

s5 = 1.0e0 + ( x + x2 * s3 );

269

s7 = 1.0e0 + ( x + x2 * s5 );

270

s9 = 1.0e0 + ( x + x2 * s7 );

271

s11 = 1.0e0 + ( x + x2 * s9 );

272

273

// SET W = DEL(B) - DEL(A + B)

274

275

t = pow ( 1.0e0 / b, 2.0 );

276

277

w = (((( c5 * s11 * t + c4

278

* s9 ) * t + c3

279

* s7 ) * t + c2

280

* s5 ) * t + c1

281

* s3 ) * t + c0;

282

w *= ( c / b );

283

284

// COMPUTE DEL(A) + W

285

286

t = pow ( 1.0e0 / a, 2.0 );

287

288

bcorr = ((((( c5 * t + c4 )

289

* t + c3 )

290

* t + c2 )

291

* t + c1 )

292

* t + c0 ) / a + w;

293

return bcorr;

294

}

295

//****************************************************************************80

296

297

double beta ( double a, double b )

298

299

//****************************************************************************80

300

301

// Purpose:

302

303

// BETA evaluates the beta function.

304

305

// Modified:

306

307

// 03 December 1999

308

309

// Author:

310

311

// John Burkardt

312

313

// Parameters:

314

315

// Input, double A, B, the arguments of the beta function.

316

317

// Output, double BETA, the value of the beta function.

318

319

{

320

return ( exp ( beta_log ( &a, &b ) ) );

321

}

322

//****************************************************************************80

323

324

double beta_asym ( double *a, double *b, double *lambda, double *eps )

325

326

//****************************************************************************80

327

328

// Purpose:

329

330

// BETA_ASYM computes an asymptotic expansion for IX(A,B), for large A and B.

331

332

// Parameters:

333

334

// Input, double *A, *B, the parameters of the function.

335

// A and B should be nonnegative. It is assumed that both A and B

336

// are greater than or equal to 15.

337

338

// Input, double *LAMBDA, the value of ( A + B ) * Y - B.

339

// It is assumed that 0 <= LAMBDA.

340

341

// Input, double *EPS, the tolerance.

342

343

{

344

static double e0 = 1.12837916709551e0;

345

static double e1 = .353553390593274e0;

346

static int num = 20;

347

348

// NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP

349

// ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.

350

// THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.

351

// E0 = 2/SQRT(PI)

352

// E1 = 2**(-3/2)

353

354

static int K3 = 1;

355

static double value;

356

static double bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0,

357

z2,zn,znm1;

358

static int i,im1,imj,j,m,mm1,mmj,n,np1;

359

static double a0[21],b0[21],c[21],d[21],T1,T2;

360

361

value = 0.0e0;

362

if(*a >= *b) goto S10;

363

h = *a/ *b;

364

r0 = 1.0e0/(1.0e0+h);

365

r1 = (*b-*a)/ *b;

366

w0 = 1.0e0/sqrt(*a*(1.0e0+h));

367

goto S20;

368

S10:

369

h = *b/ *a;

370

r0 = 1.0e0/(1.0e0+h);

371

r1 = (*b-*a)/ *a;

372

w0 = 1.0e0/sqrt(*b*(1.0e0+h));

373

S20:

374

T1 = -(*lambda/ *a);

375

T2 = *lambda/ *b;

376

f = *a*rlog1(&T1)+*b*rlog1(&T2);

377

t = exp(-f);

378

if(t == 0.0e0) return value;

379

z0 = sqrt(f);

380

z = 0.5e0*(z0/e1);

381

z2 = f+f;

382

a0[0] = 2.0e0/3.0e0*r1;

383

c[0] = -(0.5e0*a0[0]);

384

d[0] = -c[0];

385

j0 = 0.5e0/e0 * error_fc ( &K3, &z0 );

386

j1 = e1;

387

sum = j0+d[0]*w0*j1;

388

s = 1.0e0;

389

h2 = h*h;

390

hn = 1.0e0;

391

w = w0;

392

znm1 = z;

393

zn = z2;

394

for ( n = 2; n <= num; n += 2 )

395

{

396

hn = h2*hn;

397

a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0);

398

np1 = n+1;

399

s += hn;

400

a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0);

401

for ( i = n; i <= np1; i++ )

402

{

403

r = -(0.5e0*((double)i+1.0e0));

404

b0[0] = r*a0[0];

405

for ( m = 2; m <= i; m++ )

406

{

407

bsum = 0.0e0;

408

mm1 = m-1;

409

for ( j = 1; j <= mm1; j++ )

410

{

411

mmj = m-j;

412

bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]);

413

}

414

b0[m-1] = r*a0[m-1]+bsum/(double)m;

415

}

416

c[i-1] = b0[i-1]/((double)i+1.0e0);

417

dsum = 0.0e0;

418

im1 = i-1;

419

for ( j = 1; j <= im1; j++ )

420

{

421

imj = i-j;

422

dsum += (d[imj-1]*c[j-1]);

423

}

424

d[i-1] = -(dsum+c[i-1]);

425

}

426

j0 = e1*znm1+((double)n-1.0e0)*j0;

427

j1 = e1*zn+(double)n*j1;

428

znm1 = z2*znm1;

429

zn = z2*zn;

430

w = w0*w;

431

t0 = d[n-1]*w*j0;

432

w = w0*w;

433

t1 = d[np1-1]*w*j1;

434

sum += (t0+t1);

435

if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80;

436

}

437

S80:

438

u = exp(-bcorr(a,b));

439

value = e0*t*u*sum;

440

return value;

441

}

442

//****************************************************************************80

443

444

double beta_frac ( double *a, double *b, double *x, double *y, double *lambda,

445

double *eps )

446

447

//****************************************************************************80

448

449

// Purpose:

450

451

// BETA_FRAC evaluates a continued fraction expansion for IX(A,B).

452

453

// Parameters:

454

455

// Input, double *A, *B, the parameters of the function.

456

// A and B should be nonnegative. It is assumed that both A and

457

// B are greater than 1.

458

459

// Input, double *X, *Y. X is the argument of the

460

// function, and should satisy 0 <= X <= 1. Y should equal 1 - X.

461

462

// Input, double *LAMBDA, the value of ( A + B ) * Y - B.

463

464

// Input, double *EPS, a tolerance.

465

466

// Output, double BETA_FRAC, the value of the continued

467

// fraction approximation for IX(A,B).

468

469

{

470

static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1;

471

472

bfrac = beta_rcomp ( a, b, x, y );

473

474

if ( bfrac == 0.0e0 )

475

{

476

return bfrac;

477

}

478

479

c = 1.0e0+*lambda;

480

c0 = *b/ *a;

481

c1 = 1.0e0+1.0e0/ *a;

482

yp1 = *y+1.0e0;

483

n = 0.0e0;

484

p = 1.0e0;

485

s = *a+1.0e0;

486

an = 0.0e0;

487

bn = anp1 = 1.0e0;

488

bnp1 = c/c1;

489

r = c1/c;

490

491

// CONTINUED FRACTION CALCULATION

492

493

S10:

494

n = n + 1.0e0;

495

t = n/ *a;

496

w = n*(*b-n)**x;

497

e = *a/s;

498

alpha = p*(p+c0)*e*e*(w**x);

499

e = (1.0e0+t)/(c1+t+t);

500

beta = n+w/s+e*(c+n*yp1);

501

p = 1.0e0+t;

502

s += 2.0e0;

503

504

// UPDATE AN, BN, ANP1, AND BNP1

505

506

t = alpha*an+beta*anp1;

507

an = anp1;

508

anp1 = t;

509

t = alpha*bn+beta*bnp1;

510

bn = bnp1;

511

bnp1 = t;

512

r0 = r;

513

r = anp1/bnp1;

514

515

if ( fabs(r-r0) <= (*eps) * r )

516

{

517

goto S20;

518

}

519

520

// RESCALE AN, BN, ANP1, AND BNP1

521

522

an /= bnp1;

523

bn /= bnp1;

524

anp1 = r;

525

bnp1 = 1.0e0;

526

goto S10;

527

528

// TERMINATION

529

530

S20:

531

bfrac = bfrac * r;

532

return bfrac;

533

}

534

//****************************************************************************80

535

536

void beta_grat ( double *a, double *b, double *x, double *y, double *w,

537

double *eps,int *ierr )

538

539

//****************************************************************************80

540

541

// Purpose:

542

543

// BETA_GRAT evaluates an asymptotic expansion for IX(A,B).

544

545

// Parameters:

546

547

// Input, double *A, *B, the parameters of the function.

548

// A and B should be nonnegative. It is assumed that 15 <= A

549

// and B <= 1, and that B is less than A.

550

551

// Input, double *X, *Y. X is the argument of the

552

// function, and should satisy 0 <= X <= 1. Y should equal 1 - X.

553

554

// Input/output, double *W, a quantity to which the

555

// result of the computation is to be added on output.

556

557

// Input, double *EPS, a tolerance.

558

559

// Output, int *IERR, an error flag, which is 0 if no error

560

// was detected.

561

562

{

563

static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z;

564

static int i,n,nm1;

565

static double c[30],d[30],T1;

566

567

bm1 = *b-0.5e0-0.5e0;

568

nu = *a+0.5e0*bm1;

569

if(*y > 0.375e0) goto S10;

570

T1 = -*y;

571

lnx = alnrel(&T1);

572

goto S20;

573

S10:

574

lnx = log(*x);

575

S20:

576

z = -(nu*lnx);

577

if(*b*z == 0.0e0) goto S70;

578

579

// COMPUTATION OF THE EXPANSION

580

// SET R = EXP(-Z)*Z**B/GAMMA(B)

581

582

r = *b*(1.0e0+gam1(b))*exp(*b*log(z));

583

r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx));

584

u = algdiv(b,a)+*b*log(nu);

585

u = r*exp(-u);

586

if(u == 0.0e0) goto S70;

587

gamma_rat1 ( b, &z, &r, &p, &q, eps );

588

v = 0.25e0*pow(1.0e0/nu,2.0);

589

t2 = 0.25e0*lnx*lnx;

590

l = *w/u;

591

j = q/r;

592

sum = j;

593

t = cn = 1.0e0;

594

n2 = 0.0e0;

595

for ( n = 1; n <= 30; n++ )

596

{

597

bp2n = *b+n2;

598

j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v;

599

n2 = n2 + 2.0e0;

600

t *= t2;

601

cn /= (n2*(n2+1.0e0));

602

c[n-1] = cn;

603

s = 0.0e0;

604

if(n == 1) goto S40;

605

nm1 = n-1;

606

coef = *b-(double)n;

607

for ( i = 1; i <= nm1; i++ )

608

{

609

s = s + (coef*c[i-1]*d[n-i-1]);

610

coef = coef + *b;

611

}

612

S40:

613

d[n-1] = bm1*cn+s/(double)n;

614

dj = d[n-1]*j;

615

sum = sum + dj;

616

if(sum <= 0.0e0) goto S70;

617

if(fabs(dj) <= *eps*(sum+l)) goto S60;

618

}

619

S60:

620

621

// ADD THE RESULTS TO W

622

623

*ierr = 0;

624

*w = *w + (u*sum);

625

return;

626

S70:

627

628

// THE EXPANSION CANNOT BE COMPUTED

629

630

*ierr = 1;

631

return;

632

}

633

//****************************************************************************80

634

635

void beta_inc ( double *a, double *b, double *x, double *y, double *w,

636

double *w1, int *ierr )

637

638

//****************************************************************************80

639

640

// Purpose:

641

642

// BETA_INC evaluates the incomplete beta function IX(A,B).

643

644

// Author:

645

646

// Alfred H Morris, Jr,

647

// Naval Surface Weapons Center,

648

// Dahlgren, Virginia.

649

650

// Parameters:

651

652

// Input, double *A, *B, the parameters of the function.

653

// A and B should be nonnegative.

654

655

// Input, double *X, *Y. X is the argument of the

656

// function, and should satisy 0 <= X <= 1. Y should equal 1 - X.

657

658

// Output, double *W, *W1, the values of IX(A,B) and

659

// 1-IX(A,B).

660

661

// Output, int *IERR, the error flag.

662

// 0, no error was detected.

663

// 1, A or B is negative;

664

// 2, A = B = 0;

665

// 3, X < 0 or 1 < X;

666

// 4, Y < 0 or 1 < Y;

667

// 5, X + Y /= 1;

668

// 6, X = A = 0;

669

// 7, Y = B = 0.

670

671

{

672

static int K1 = 1;

673

static double a0,b0,eps,lambda,t,x0,y0,z;

674

static int ierr1,ind,n;

675

static double T2,T3,T4,T5;

676

677

// EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST

678

// NUMBER FOR WHICH 1.0 + EPS .GT. 1.0

679

680

eps = dpmpar ( &K1 );

681

*w = *w1 = 0.0e0;

682

if(*a < 0.0e0 || *b < 0.0e0) goto S270;

683

if(*a == 0.0e0 && *b == 0.0e0) goto S280;

684

if(*x < 0.0e0 || *x > 1.0e0) goto S290;

685

if(*y < 0.0e0 || *y > 1.0e0) goto S300;

686

z = *x+*y-0.5e0-0.5e0;

687

if(fabs(z) > 3.0e0*eps) goto S310;

688

*ierr = 0;

689

if(*x == 0.0e0) goto S210;

690

if(*y == 0.0e0) goto S230;

691

if(*a == 0.0e0) goto S240;

692

if(*b == 0.0e0) goto S220;

693

eps = fifdmax1(eps,1.e-15);

694

if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260;

695

ind = 0;

696

a0 = *a;

697

b0 = *b;

698

x0 = *x;

699

y0 = *y;

700

if(fifdmin1(a0,b0) > 1.0e0) goto S40;

701

702

// PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1

703

704

if(*x <= 0.5e0) goto S10;

705

ind = 1;

706

a0 = *b;

707

b0 = *a;

708

x0 = *y;

709

y0 = *x;

710

S10:

711

if(b0 < fifdmin1(eps,eps*a0)) goto S90;

712

if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100;

713

if(fifdmax1(a0,b0) > 1.0e0) goto S20;

714

if(a0 >= fifdmin1(0.2e0,b0)) goto S110;

715

if(pow(x0,a0) <= 0.9e0) goto S110;

716

if(x0 >= 0.3e0) goto S120;

717

n = 20;

718

goto S140;

719

S20:

720

if(b0 <= 1.0e0) goto S110;

721

if(x0 >= 0.3e0) goto S120;

722

if(x0 >= 0.1e0) goto S30;

723

if(pow(x0*b0,a0) <= 0.7e0) goto S110;

724

S30:

725

if(b0 > 15.0e0) goto S150;

726

n = 20;

727

goto S140;

728

S40:

729

730

// PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1

731

732

if(*a > *b) goto S50;

733

lambda = *a-(*a+*b)**x;

734

goto S60;

735

S50:

736

lambda = (*a+*b)**y-*b;

737

S60:

738

if(lambda >= 0.0e0) goto S70;

739

ind = 1;

740

a0 = *b;

741

b0 = *a;

742

x0 = *y;

743

y0 = *x;

744

lambda = fabs(lambda);

745

S70:

746

if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110;

747

if(b0 < 40.0e0) goto S160;

748

if(a0 > b0) goto S80;

749

if(a0 <= 100.0e0) goto S130;

750

if(lambda > 0.03e0*a0) goto S130;

751

goto S200;

752

S80:

753

if(b0 <= 100.0e0) goto S130;

754

if(lambda > 0.03e0*b0) goto S130;

755

goto S200;

756

S90:

757

758

// EVALUATION OF THE APPROPRIATE ALGORITHM

759

760

*w = fpser(&a0,&b0,&x0,&eps);

761

*w1 = 0.5e0+(0.5e0-*w);

762

goto S250;

763

S100:

764

*w1 = apser(&a0,&b0,&x0,&eps);

765

*w = 0.5e0+(0.5e0-*w1);

766

goto S250;

767

S110:

768

*w = beta_pser(&a0,&b0,&x0,&eps);

769

*w1 = 0.5e0+(0.5e0-*w);

770

goto S250;

771

S120:

772

*w1 = beta_pser(&b0,&a0,&y0,&eps);

773

*w = 0.5e0+(0.5e0-*w1);

774

goto S250;

775

S130:

776

T2 = 15.0e0*eps;

777

*w = beta_frac ( &a0,&b0,&x0,&y0,&lambda,&T2 );

778

*w1 = 0.5e0+(0.5e0-*w);

779

goto S250;

780

S140:

781

*w1 = beta_up ( &b0, &a0, &y0, &x0, &n, &eps );

782

b0 = b0 + (double)n;

783

S150:

784

T3 = 15.0e0*eps;

785

beta_grat (&b0,&a0,&y0,&x0,w1,&T3,&ierr1);

786

*w = 0.5e0+(0.5e0-*w1);

787

goto S250;

788

S160:

789

n = ( int ) b0;

790

b0 -= (double)n;

791

if(b0 != 0.0e0) goto S170;

792

n -= 1;

793

b0 = 1.0e0;

794

S170:

795

*w = beta_up ( &b0, &a0, &y0, &x0, &n, &eps );

796

if(x0 > 0.7e0) goto S180;

797

*w = *w + beta_pser(&a0,&b0,&x0,&eps);

798

*w1 = 0.5e0+(0.5e0-*w);

799

goto S250;

800

S180:

801

if(a0 > 15.0e0) goto S190;

802

n = 20;

803

*w = *w + beta_up ( &a0, &b0, &x0, &y0, &n, &eps );

804

a0 = a0 + (double)n;

805

S190:

806

T4 = 15.0e0*eps;

807

beta_grat ( &a0, &b0, &x0, &y0, w, &T4, &ierr1 );

808

*w1 = 0.5e0+(0.5e0-*w);

809

goto S250;

810

S200:

811

T5 = 100.0e0*eps;

812

*w = beta_asym ( &a0, &b0, &lambda, &T5 );

813

*w1 = 0.5e0+(0.5e0-*w);

814

goto S250;

815

S210:

816

817

// TERMINATION OF THE PROCEDURE

818

819

if(*a == 0.0e0) goto S320;

820

S220:

821

*w = 0.0e0;

822

*w1 = 1.0e0;

823

return;

824

S230:

825

if(*b == 0.0e0) goto S330;

826

S240:

827

*w = 1.0e0;

828

*w1 = 0.0e0;

829

return;

830

S250:

831

if(ind == 0) return;

832

t = *w;

833

*w = *w1;

834

*w1 = t;

835

return;

836

S260:

837

838

// PROCEDURE FOR A AND B .LT. 1.E-3*EPS

839

840

*w = *b/(*a+*b);

841

*w1 = *a/(*a+*b);

842

return;

843

S270:

844

845

// ERROR RETURN

846

847

*ierr = 1;

848

return;

849

S280:

850

*ierr = 2;

851

return;

852

S290:

853

*ierr = 3;

854

return;

855

S300:

856

*ierr = 4;

857

return;

858

S310:

859

*ierr = 5;

860

return;

861

S320:

862

*ierr = 6;

863

return;

864

S330:

865

*ierr = 7;

866

return;

867

}

868

//****************************************************************************80

869

870

void beta_inc_values ( int *n_data, double *a, double *b, double *x,

871

double *fx )

872

873

//****************************************************************************80

874

875

// Purpose:

876

877

// BETA_INC_VALUES returns some values of the incomplete Beta function.

878

879

// Discussion:

880

881

// The incomplete Beta function may be written

882

883

// BETA_INC(A,B,X) = Integral (0 to X) T**(A-1) * (1-T)**(B-1) dT

884

// / Integral (0 to 1) T**(A-1) * (1-T)**(B-1) dT

885

886

// Thus,

887

888

// BETA_INC(A,B,0.0) = 0.0

889

// BETA_INC(A,B,1.0) = 1.0

890

891

// Note that in Mathematica, the expressions:

892

893

// BETA[A,B] = Integral (0 to 1) T**(A-1) * (1-T)**(B-1) dT

894

// BETA[X,A,B] = Integral (0 to X) T**(A-1) * (1-T)**(B-1) dT

895

896

// and thus, to evaluate the incomplete Beta function requires:

897

898

// BETA_INC(A,B,X) = BETA[X,A,B] / BETA[A,B]

899

900

// Modified:

901

902

// 09 June 2004

903

904

// Author:

905

906

// John Burkardt

907

908

// Reference:

909

910

// Milton Abramowitz and Irene Stegun,

911

// Handbook of Mathematical Functions,

912

// US Department of Commerce, 1964.

913

914

// Karl Pearson,

915

// Tables of the Incomplete Beta Function,

916

// Cambridge University Press, 1968.

917

918

// Parameters:

919

920

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

921

// first call. On each call, the routine increments N_DATA by 1, and

922

// returns the corresponding data; when there is no more data, the

923

// output value of N_DATA will be 0 again.

924

925

// Output, double *A, *B, the parameters of the function.

926

927

// Output, double *X, the argument of the function.

928

929

// Output, double *FX, the value of the function.

930

931

{

932

# define N_MAX 30

933

934

double a_vec[N_MAX] = {

935

0.5E+00, 0.5E+00, 0.5E+00, 1.0E+00,

936

1.0E+00, 1.0E+00, 1.0E+00, 1.0E+00,

937

2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,

938

2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,

939

2.0E+00, 5.5E+00, 10.0E+00, 10.0E+00,

940

10.0E+00, 10.0E+00, 20.0E+00, 20.0E+00,

941

20.0E+00, 20.0E+00, 20.0E+00, 30.0E+00,

942

30.0E+00, 40.0E+00 };

943

double b_vec[N_MAX] = {

944

0.5E+00, 0.5E+00, 0.5E+00, 0.5E+00,

945

0.5E+00, 0.5E+00, 0.5E+00, 1.0E+00,

946

2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,

947

2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,

948

2.0E+00, 5.0E+00, 0.5E+00, 5.0E+00,

949

5.0E+00, 10.0E+00, 5.0E+00, 10.0E+00,

950

10.0E+00, 20.0E+00, 20.0E+00, 10.0E+00,

951

10.0E+00, 20.0E+00 };

952

double fx_vec[N_MAX] = {

953

0.0637686E+00, 0.2048328E+00, 1.0000000E+00, 0.0E+00,

954

0.0050126E+00, 0.0513167E+00, 0.2928932E+00, 0.5000000E+00,

955

0.028E+00, 0.104E+00, 0.216E+00, 0.352E+00,

956

0.500E+00, 0.648E+00, 0.784E+00, 0.896E+00,

957

0.972E+00, 0.4361909E+00, 0.1516409E+00, 0.0897827E+00,

958

1.0000000E+00, 0.5000000E+00, 0.4598773E+00, 0.2146816E+00,

959

0.9507365E+00, 0.5000000E+00, 0.8979414E+00, 0.2241297E+00,

960

0.7586405E+00, 0.7001783E+00 };

961

double x_vec[N_MAX] = {

962

0.01E+00, 0.10E+00, 1.00E+00, 0.0E+00,

963

0.01E+00, 0.10E+00, 0.50E+00, 0.50E+00,

964

0.1E+00, 0.2E+00, 0.3E+00, 0.4E+00,

965

0.5E+00, 0.6E+00, 0.7E+00, 0.8E+00,

966

0.9E+00, 0.50E+00, 0.90E+00, 0.50E+00,

967

1.00E+00, 0.50E+00, 0.80E+00, 0.60E+00,

968

0.80E+00, 0.50E+00, 0.60E+00, 0.70E+00,

969

0.80E+00, 0.70E+00 };

970

971

if ( *n_data < 0 )

972

{

973

*n_data = 0;

974

}

975

976

*n_data = *n_data + 1;

977

978

if ( N_MAX < *n_data )

979

{

980

*n_data = 0;

981

*a = 0.0E+00;

982

*b = 0.0E+00;

983

*x = 0.0E+00;

984

*fx = 0.0E+00;

985

}

986

else

987

{

988

*a = a_vec[*n_data-1];

989

*b = b_vec[*n_data-1];

990

*x = x_vec[*n_data-1];

991

*fx = fx_vec[*n_data-1];

992

}

993

return;

994

# undef N_MAX

995

}

996

//****************************************************************************80

997

998

double beta_log ( double *a0, double *b0 )

999

1000

//****************************************************************************80

1001

1002

// Purpose:

1003

1004

// BETA_LOG evaluates the logarithm of the beta function.

1005

1006

// Reference:

1007

1008

// Armido DiDinato and Alfred Morris,

1009

// Algorithm 708:

1010

// Significant Digit Computation of the Incomplete Beta Function Ratios,

1011

// ACM Transactions on Mathematical Software,

1012

// Volume 18, 1993, pages 360-373.

1013

1014

// Parameters:

1015

1016

// Input, double *A0, *B0, the parameters of the function.

1017

// A0 and B0 should be nonnegative.

1018

1019

// Output, double *BETA_LOG, the value of the logarithm

1020

// of the Beta function.

1021

1022

{

1023

static double e = .918938533204673e0;

1024

static double value,a,b,c,h,u,v,w,z;

1025

static int i,n;

1026

static double T1;

1027

1028

a = fifdmin1(*a0,*b0);

1029

b = fifdmax1(*a0,*b0);

1030

if(a >= 8.0e0) goto S100;

1031

if(a >= 1.0e0) goto S20;

1032

1033

// PROCEDURE WHEN A .LT. 1

1034

1035

if(b >= 8.0e0) goto S10;

1036

T1 = a+b;

1037

value = gamma_log ( &a )+( gamma_log ( &b )- gamma_log ( &T1 ));

1038

return value;

1039

S10:

1040

value = gamma_log ( &a )+algdiv(&a,&b);

1041

return value;

1042

S20:

1043

1044

// PROCEDURE WHEN 1 .LE. A .LT. 8

1045

1046

if(a > 2.0e0) goto S40;

1047

if(b > 2.0e0) goto S30;

1048

value = gamma_log ( &a )+ gamma_log ( &b )-gsumln(&a,&b);

1049

return value;

1050

S30:

1051

w = 0.0e0;

1052

if(b < 8.0e0) goto S60;

1053

value = gamma_log ( &a )+algdiv(&a,&b);

1054

return value;

1055

S40:

1056

1057

// REDUCTION OF A WHEN B .LE. 1000

1058

1059

if(b > 1000.0e0) goto S80;

1060

n = ( int ) ( a - 1.0e0 );

1061

w = 1.0e0;

1062

for ( i = 1; i <= n; i++ )

1063

{

1064

a -= 1.0e0;

1065

h = a/b;

1066

w *= (h/(1.0e0+h));

1067

}

1068

w = log(w);

1069

if(b < 8.0e0) goto S60;

1070

value = w+ gamma_log ( &a )+algdiv(&a,&b);

1071

return value;

1072

S60:

1073

1074

// REDUCTION OF B WHEN B .LT. 8

1075

1076

n = ( int ) ( b - 1.0e0 );

1077

z = 1.0e0;

1078

for ( i = 1; i <= n; i++ )

1079

{

1080

b -= 1.0e0;

1081

z *= (b/(a+b));

1082

}

1083

value = w+log(z)+( gamma_log ( &a )+( gamma_log ( &b )-gsumln(&a,&b)));

1084

return value;

1085

S80:

1086

1087

// REDUCTION OF A WHEN B .GT. 1000

1088

1089

n = ( int ) ( a - 1.0e0 );

1090

w = 1.0e0;

1091

for ( i = 1; i <= n; i++ )

1092

{

1093

a -= 1.0e0;

1094

w *= (a/(1.0e0+a/b));

1095

}

1096

value = log(w)-(double)n*log(b)+( gamma_log ( &a )+algdiv(&a,&b));

1097

return value;

1098

S100:

1099

1100

// PROCEDURE WHEN A .GE. 8

1101

1102

w = bcorr(&a,&b);

1103

h = a/b;

1104

c = h/(1.0e0+h);

1105

u = -((a-0.5e0)*log(c));

1106

v = b*alnrel(&h);

1107

if(u <= v) goto S110;

1108

value = -(0.5e0*log(b))+e+w-v-u;

1109

return value;

1110

S110:

1111

value = -(0.5e0*log(b))+e+w-u-v;

1112

return value;

1113

}

1114

//****************************************************************************80

1115

1116

double beta_pser ( double *a, double *b, double *x, double *eps )

1117

1118

//****************************************************************************80

1119

1120

// Purpose:

1121

1122

// BETA_PSER uses a power series expansion to evaluate IX(A,B)(X).

1123

1124

// Discussion:

1125

1126

// BETA_PSER is used when B <= 1 or B*X <= 0.7.

1127

1128

// Parameters:

1129

1130

// Input, double *A, *B, the parameters.

1131

1132

// Input, double *X, the point where the function

1133

// is to be evaluated.

1134

1135

// Input, double *EPS, the tolerance.

1136

1137

// Output, double BETA_PSER, the approximate value of IX(A,B)(X).

1138

1139

{

1140

static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z;

1141

static int i,m;

1142

1143

bpser = 0.0e0;

1144

if(*x == 0.0e0) return bpser;

1145

1146

// COMPUTE THE FACTOR X**A/(A*BETA(A,B))

1147

1148

a0 = fifdmin1(*a,*b);

1149

if(a0 < 1.0e0) goto S10;

1150

z = *a*log(*x)-beta_log(a,b);

1151

bpser = exp(z)/ *a;

1152

goto S100;

1153

S10:

1154

b0 = fifdmax1(*a,*b);

1155

if(b0 >= 8.0e0) goto S90;

1156

if(b0 > 1.0e0) goto S40;

1157

1158

// PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1

1159

1160

bpser = pow(*x,*a);

1161

if(bpser == 0.0e0) return bpser;

1162

apb = *a+*b;

1163

if(apb > 1.0e0) goto S20;

1164

z = 1.0e0+gam1(&apb);

1165

goto S30;

1166

S20:

1167

u = *a+*b-1.e0;

1168

z = (1.0e0+gam1(&u))/apb;

1169

S30:

1170

c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;

1171

bpser *= (c*(*b/apb));

1172

goto S100;

1173

S40:

1174

1175

// PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8

1176

1177

u = gamma_ln1 ( &a0 );

1178

m = ( int ) ( b0 - 1.0e0 );

1179

if(m < 1) goto S60;

1180

c = 1.0e0;

1181

for ( i = 1; i <= m; i++ )

1182

{

1183

b0 -= 1.0e0;

1184

c *= (b0/(a0+b0));

1185

}

1186

u = log(c)+u;

1187

S60:

1188

z = *a*log(*x)-u;

1189

b0 -= 1.0e0;

1190

apb = a0+b0;

1191

if(apb > 1.0e0) goto S70;

1192

t = 1.0e0+gam1(&apb);

1193

goto S80;

1194

S70:

1195

u = a0+b0-1.e0;

1196

t = (1.0e0+gam1(&u))/apb;

1197

S80:

1198

bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t;

1199

goto S100;

1200

S90:

1201

1202

// PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8

1203

1204

u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );

1205

z = *a*log(*x)-u;

1206

bpser = a0/ *a*exp(z);

1207

S100:

1208

if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser;

1209

1210

// COMPUTE THE SERIES

1211

1212

sum = n = 0.0e0;

1213

c = 1.0e0;

1214

tol = *eps/ *a;

1215

S110:

1216

n = n + 1.0e0;

1217

c *= ((0.5e0+(0.5e0-*b/n))**x);

1218

w = c/(*a+n);

1219

sum = sum + w;

1220

if(fabs(w) > tol) goto S110;

1221

bpser *= (1.0e0+*a*sum);

1222

return bpser;

1223

}

1224

//****************************************************************************80

1225

1226

double beta_rcomp ( double *a, double *b, double *x, double *y )

1227

1228

//****************************************************************************80

1229

1230

// Purpose:

1231

1232

// BETA_RCOMP evaluates X**A * Y**B / Beta(A,B).

1233

1234

// Parameters:

1235

1236

// Input, double *A, *B, the parameters of the Beta function.

1237

// A and B should be nonnegative.

1238

1239

// Input, double *X, *Y, define the numerator of the fraction.

1240

1241

// Output, double BETA_RCOMP, the value of X**A * Y**B / Beta(A,B).

1242

1243

{

1244

static double Const = .398942280401433e0;

1245

static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;

1246

static int i,n;

1247

1248

// CONST = 1/SQRT(2*PI)

1249

1250

static double T1,T2;

1251

1252

brcomp = 0.0e0;

1253

if(*x == 0.0e0 || *y == 0.0e0) return brcomp;

1254

a0 = fifdmin1(*a,*b);

1255

if(a0 >= 8.0e0) goto S130;

1256

if(*x > 0.375e0) goto S10;

1257

lnx = log(*x);

1258

T1 = -*x;

1259

lny = alnrel(&T1);

1260

goto S30;

1261

S10:

1262

if(*y > 0.375e0) goto S20;

1263

T2 = -*y;

1264

lnx = alnrel(&T2);

1265

lny = log(*y);

1266

goto S30;

1267

S20:

1268

lnx = log(*x);

1269

lny = log(*y);

1270

S30:

1271

z = *a*lnx+*b*lny;

1272

if(a0 < 1.0e0) goto S40;

1273

z -= beta_log(a,b);

1274

brcomp = exp(z);

1275

return brcomp;

1276

S40:

1277

1278

// PROCEDURE FOR A .LT. 1 OR B .LT. 1

1279

1280

b0 = fifdmax1(*a,*b);

1281

if(b0 >= 8.0e0) goto S120;

1282

if(b0 > 1.0e0) goto S70;

1283

1284

// ALGORITHM FOR B0 .LE. 1

1285

1286

brcomp = exp(z);

1287

if(brcomp == 0.0e0) return brcomp;

1288

apb = *a+*b;

1289

if(apb > 1.0e0) goto S50;

1290

z = 1.0e0+gam1(&apb);

1291

goto S60;

1292

S50:

1293

u = *a+*b-1.e0;

1294

z = (1.0e0+gam1(&u))/apb;

1295

S60:

1296

c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;

1297

brcomp = brcomp*(a0*c)/(1.0e0+a0/b0);

1298

return brcomp;

1299

S70:

1300

1301

// ALGORITHM FOR 1 .LT. B0 .LT. 8

1302

1303

u = gamma_ln1 ( &a0 );

1304

n = ( int ) ( b0 - 1.0e0 );

1305

if(n < 1) goto S90;

1306

c = 1.0e0;

1307

for ( i = 1; i <= n; i++ )

1308

{

1309

b0 -= 1.0e0;

1310

c *= (b0/(a0+b0));

1311

}

1312

u = log(c)+u;

1313

S90:

1314

z -= u;

1315

b0 -= 1.0e0;

1316

apb = a0+b0;

1317

if(apb > 1.0e0) goto S100;

1318

t = 1.0e0+gam1(&apb);

1319

goto S110;

1320

S100:

1321

u = a0+b0-1.e0;

1322

t = (1.0e0+gam1(&u))/apb;

1323

S110:

1324

brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t;

1325

return brcomp;

1326

S120:

1327

1328

// ALGORITHM FOR B0 .GE. 8

1329

1330

u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );

1331

brcomp = a0*exp(z-u);

1332

return brcomp;

1333

S130:

1334

1335

// PROCEDURE FOR A .GE. 8 AND B .GE. 8

1336

1337

if(*a > *b) goto S140;

1338

h = *a/ *b;

1339

x0 = h/(1.0e0+h);

1340

y0 = 1.0e0/(1.0e0+h);

1341

lambda = *a-(*a+*b)**x;

1342

goto S150;

1343

S140:

1344

h = *b/ *a;

1345

x0 = 1.0e0/(1.0e0+h);

1346

y0 = h/(1.0e0+h);

1347

lambda = (*a+*b)**y-*b;

1348

S150:

1349

e = -(lambda/ *a);

1350

if(fabs(e) > 0.6e0) goto S160;

1351

u = rlog1(&e);

1352

goto S170;

1353

S160:

1354

u = e-log(*x/x0);

1355

S170:

1356

e = lambda/ *b;

1357

if(fabs(e) > 0.6e0) goto S180;

1358

v = rlog1(&e);

1359

goto S190;

1360

S180:

1361

v = e-log(*y/y0);

1362

S190:

1363

z = exp(-(*a*u+*b*v));

1364

brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));

1365

return brcomp;

1366

}

1367

//****************************************************************************80

1368

1369

double beta_rcomp1 ( int *mu, double *a, double *b, double *x, double *y )

1370

1371

//****************************************************************************80

1372

1373

// Purpose:

1374

1375

// BETA_RCOMP1 evaluates exp(MU) * X**A * Y**B / Beta(A,B).

1376

1377

// Parameters:

1378

1379

// Input, int MU, ?

1380

1381

// Input, double A, B, the parameters of the Beta function.

1382

// A and B should be nonnegative.

1383

1384

// Input, double X, Y, ?

1385

1386

// Output, double BETA_RCOMP1, the value of

1387

// exp(MU) * X**A * Y**B / Beta(A,B).

1388

1389

{

1390

static double Const = .398942280401433e0;

1391

static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;

1392

static int i,n;

1393

1394

// CONST = 1/SQRT(2*PI)

1395

1396

static double T1,T2,T3,T4;

1397

1398

a0 = fifdmin1(*a,*b);

1399

if(a0 >= 8.0e0) goto S130;

1400

if(*x > 0.375e0) goto S10;

1401

lnx = log(*x);

1402

T1 = -*x;

1403

lny = alnrel(&T1);

1404

goto S30;

1405

S10:

1406

if(*y > 0.375e0) goto S20;

1407

T2 = -*y;

1408

lnx = alnrel(&T2);

1409

lny = log(*y);

1410

goto S30;

1411

S20:

1412

lnx = log(*x);

1413

lny = log(*y);

1414

S30:

1415

z = *a*lnx+*b*lny;

1416

if(a0 < 1.0e0) goto S40;

1417

z -= beta_log(a,b);

1418

brcmp1 = esum(mu,&z);

1419

return brcmp1;

1420

S40:

1421

1422

// PROCEDURE FOR A .LT. 1 OR B .LT. 1

1423

1424

b0 = fifdmax1(*a,*b);

1425

if(b0 >= 8.0e0) goto S120;

1426

if(b0 > 1.0e0) goto S70;

1427

1428

// ALGORITHM FOR B0 .LE. 1

1429

1430

brcmp1 = esum(mu,&z);

1431

if(brcmp1 == 0.0e0) return brcmp1;

1432

apb = *a+*b;

1433

if(apb > 1.0e0) goto S50;

1434

z = 1.0e0+gam1(&apb);

1435

goto S60;

1436

S50:

1437

u = *a+*b-1.e0;

1438

z = (1.0e0+gam1(&u))/apb;

1439

S60:

1440

c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;

1441

brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0);

1442

return brcmp1;

1443

S70:

1444

1445

// ALGORITHM FOR 1 .LT. B0 .LT. 8

1446

1447

u = gamma_ln1 ( &a0 );

1448

n = ( int ) ( b0 - 1.0e0 );

1449

if(n < 1) goto S90;

1450

c = 1.0e0;

1451

for ( i = 1; i <= n; i++ )

1452

{

1453

b0 -= 1.0e0;

1454

c *= (b0/(a0+b0));

1455

}

1456

u = log(c)+u;

1457

S90:

1458

z -= u;

1459

b0 -= 1.0e0;

1460

apb = a0+b0;

1461

if(apb > 1.0e0) goto S100;

1462

t = 1.0e0+gam1(&apb);

1463

goto S110;

1464

S100:

1465

u = a0+b0-1.e0;

1466

t = (1.0e0+gam1(&u))/apb;

1467

S110:

1468

brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t;

1469

return brcmp1;

1470

S120:

1471

1472

// ALGORITHM FOR B0 .GE. 8

1473

1474

u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );

1475

T3 = z-u;

1476

brcmp1 = a0*esum(mu,&T3);

1477

return brcmp1;

1478

S130:

1479

1480

// PROCEDURE FOR A .GE. 8 AND B .GE. 8

1481

1482

if(*a > *b) goto S140;

1483

h = *a/ *b;

1484

x0 = h/(1.0e0+h);

1485

y0 = 1.0e0/(1.0e0+h);

1486

lambda = *a-(*a+*b)**x;

1487

goto S150;

1488

S140:

1489

h = *b/ *a;

1490

x0 = 1.0e0/(1.0e0+h);

1491

y0 = h/(1.0e0+h);

1492

lambda = (*a+*b)**y-*b;

1493

S150:

1494

e = -(lambda/ *a);

1495

if(fabs(e) > 0.6e0) goto S160;

1496

u = rlog1(&e);

1497

goto S170;

1498

S160:

1499

u = e-log(*x/x0);

1500

S170:

1501

e = lambda/ *b;

1502

if(fabs(e) > 0.6e0) goto S180;

1503

v = rlog1(&e);

1504

goto S190;

1505

S180:

1506

v = e-log(*y/y0);

1507

S190:

1508

T4 = -(*a*u+*b*v);

1509

z = esum(mu,&T4);

1510

brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));

1511

return brcmp1;

1512

}

1513

//****************************************************************************80

1514

1515

double beta_up ( double *a, double *b, double *x, double *y, int *n,

1516

double *eps )

1517

1518

//****************************************************************************80

1519

1520

// Purpose:

1521

1522

// BETA_UP evaluates IX(A,B) - IX(A+N,B) where N is a positive integer.

1523

1524

// Parameters:

1525

1526

// Input, double *A, *B, the parameters of the function.

1527

// A and B should be nonnegative.

1528

1529

// Input, double *X, *Y, ?

1530

1531

// Input, int *N, ?

1532

1533

// Input, double *EPS, the tolerance.

1534

1535

// Output, double BETA_UP, the value of IX(A,B) - IX(A+N,B).

1536

1537

{

1538

static int K1 = 1;

1539

static int K2 = 0;

1540

static double bup,ap1,apb,d,l,r,t,w;

1541

static int i,k,kp1,mu,nm1;

1542

1543

// OBTAIN THE SCALING FACTOR EXP(-MU) AND

1544

// EXP(MU)*(X**A*Y**B/BETA(A,B))/A

1545

1546

apb = *a+*b;

1547

ap1 = *a+1.0e0;

1548

mu = 0;

1549

d = 1.0e0;

1550

if(*n == 1 || *a < 1.0e0) goto S10;

1551

if(apb < 1.1e0*ap1) goto S10;

1552

mu = ( int ) fabs ( exparg(&K1) );

1553

k = ( int ) exparg ( &K2 );

1554

if(k < mu) mu = k;

1555

t = mu;

1556

d = exp(-t);

1557

S10:

1558

bup = beta_rcomp1 ( &mu, a, b, x, y ) / *a;

1559

if(*n == 1 || bup == 0.0e0) return bup;

1560

nm1 = *n-1;

1561

w = d;

1562

1563

// LET K BE THE INDEX OF THE MAXIMUM TERM

1564

1565

k = 0;

1566

if(*b <= 1.0e0) goto S50;

1567

if(*y > 1.e-4) goto S20;

1568

k = nm1;

1569

goto S30;

1570

S20:

1571

r = (*b-1.0e0)**x/ *y-*a;

1572

if(r < 1.0e0) goto S50;

1573

t = ( double ) nm1;

1574

k = nm1;

1575

if ( r < t ) k = ( int ) r;

1576

S30:

1577

1578

// ADD THE INCREASING TERMS OF THE SERIES

1579

1580

for ( i = 1; i <= k; i++ )

1581

{

1582

l = i-1;

1583

d = (apb+l)/(ap1+l)**x*d;

1584

w = w + d;

1585

}

1586

if(k == nm1) goto S70;

1587

S50:

1588

1589

// ADD THE REMAINING TERMS OF THE SERIES

1590

1591

kp1 = k+1;

1592

for ( i = kp1; i <= nm1; i++ )

1593

{

1594

l = i-1;

1595

d = (apb+l)/(ap1+l)**x*d;

1596

w = w + d;

1597

if(d <= *eps*w) goto S70;

1598

}

1599

S70:

1600

1601

// TERMINATE THE PROCEDURE

1602

1603

bup *= w;

1604

return bup;

1605

}

1606

//****************************************************************************80

1607

1608

void binomial_cdf_values ( int *n_data, int *a, double *b, int *x, double *fx )

1609

1610

//****************************************************************************80

1611

1612

// Purpose:

1613

1614

// BINOMIAL_CDF_VALUES returns some values of the binomial CDF.

1615

1616

// Discussion:

1617

1618

// CDF(X)(A,B) is the probability of at most X successes in A trials,

1619

// given that the probability of success on a single trial is B.

1620

1621

// Modified:

1622

1623

// 31 May 2004

1624

1625

// Author:

1626

1627

// John Burkardt

1628

1629

// Reference:

1630

1631

// Milton Abramowitz and Irene Stegun,

1632

// Handbook of Mathematical Functions,

1633

// US Department of Commerce, 1964.

1634

1635

// Daniel Zwillinger,

1636

// CRC Standard Mathematical Tables and Formulae,

1637

// 30th Edition, CRC Press, 1996, pages 651-652.

1638

1639

// Parameters:

1640

1641

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

1642

// first call. On each call, the routine increments N_DATA by 1, and

1643

// returns the corresponding data; when there is no more data, the

1644

// output value of N_DATA will be 0 again.

1645

1646

// Output, int *A, double *B, the parameters of the function.

1647

1648

// Output, int *X, the argument of the function.

1649

1650

// Output, double *FX, the value of the function.

1651

1652

{

1653

# define N_MAX 17

1654

1655

int a_vec[N_MAX] = {

1656

2, 2, 2, 2,

1657

2, 4, 4, 4,

1658

4, 10, 10, 10,

1659

10, 10, 10, 10,

1660

10 };

1661

double b_vec[N_MAX] = {

1662

0.05E+00, 0.05E+00, 0.05E+00, 0.50E+00,

1663

0.50E+00, 0.25E+00, 0.25E+00, 0.25E+00,

1664

0.25E+00, 0.05E+00, 0.10E+00, 0.15E+00,

1665

0.20E+00, 0.25E+00, 0.30E+00, 0.40E+00,

1666

0.50E+00 };

1667

double fx_vec[N_MAX] = {

1668

0.9025E+00, 0.9975E+00, 1.0000E+00, 0.2500E+00,

1669

0.7500E+00, 0.3164E+00, 0.7383E+00, 0.9492E+00,

1670

0.9961E+00, 0.9999E+00, 0.9984E+00, 0.9901E+00,

1671

0.9672E+00, 0.9219E+00, 0.8497E+00, 0.6331E+00,

1672

0.3770E+00 };

1673

int x_vec[N_MAX] = {

1674

0, 1, 2, 0,

1675

1, 0, 1, 2,

1676

3, 4, 4, 4,

1677

4, 4, 4, 4,

1678

4 };

1679

1680

if ( *n_data < 0 )

1681

{

1682

*n_data = 0;

1683

}

1684

1685

*n_data = *n_data + 1;

1686

1687

if ( N_MAX < *n_data )

1688

{

1689

*n_data = 0;

1690

*a = 0;

1691

*b = 0.0E+00;

1692

*x = 0;

1693

*fx = 0.0E+00;

1694

}

1695

else

1696

{

1697

*a = a_vec[*n_data-1];

1698

*b = b_vec[*n_data-1];

1699

*x = x_vec[*n_data-1];

1700

*fx = fx_vec[*n_data-1];

1701

}

1702

return;

1703

# undef N_MAX

1704

}

1705

//****************************************************************************80

1706

1707

void cdfbet ( int *which, double *p, double *q, double *x, double *y,

1708

double *a, double *b, int *status, double *bound )

1709

1710

//****************************************************************************80

1711

1712

// Purpose:

1713

1714

// CDFBET evaluates the CDF of the Beta Distribution.

1715

1716

// Discussion:

1717

1718

// This routine calculates any one parameter of the beta distribution

1719

// given the others.

1720

1721

// The value P of the cumulative distribution function is calculated

1722

// directly by code associated with the reference.

1723

1724

// Computation of the other parameters involves a seach for a value that

1725

// produces the desired value of P. The search relies on the

1726

// monotonicity of P with respect to the other parameters.

1727

1728

// The beta density is proportional to t^(A-1) * (1-t)^(B-1).

1729

1730

// Modified:

1731

1732

// 09 June 2004

1733

1734

// Reference:

1735

1736

// Armido DiDinato and Alfred Morris,

1737

// Algorithm 708:

1738

// Significant Digit Computation of the Incomplete Beta Function Ratios,

1739

// ACM Transactions on Mathematical Software,

1740

// Volume 18, 1993, pages 360-373.

1741

1742

// Parameters:

1743

1744

// Input, int *WHICH, indicates which of the next four argument

1745

// values is to be calculated from the others.

1746

// 1: Calculate P and Q from X, Y, A and B;

1747

// 2: Calculate X and Y from P, Q, A and B;

1748

// 3: Calculate A from P, Q, X, Y and B;

1749

// 4: Calculate B from P, Q, X, Y and A.

1750

1751

// Input/output, double *P, the integral from 0 to X of the

1752

// chi-square distribution. Input range: [0, 1].

1753

1754

// Input/output, double *Q, equals 1-P. Input range: [0, 1].

1755

1756

// Input/output, double *X, the upper limit of integration

1757

// of the beta density. If it is an input value, it should lie in

1758

// the range [0,1]. If it is an output value, it will be searched for

1759

// in the range [0,1].

1760

1761

// Input/output, double *Y, equal to 1-X. If it is an input

1762

// value, it should lie in the range [0,1]. If it is an output value,

1763

// it will be searched for in the range [0,1].

1764

1765

// Input/output, double *A, the first parameter of the beta

1766

// density. If it is an input value, it should lie in the range

1767

// (0, +infinity). If it is an output value, it will be searched

1768

// for in the range [1D-300,1D300].

1769

1770

// Input/output, double *B, the second parameter of the beta

1771

// density. If it is an input value, it should lie in the range

1772

// (0, +infinity). If it is an output value, it will be searched

1773

// for in the range [1D-300,1D300].

1774

1775

// Output, int *STATUS, reports the status of the computation.

1776

// 0, if the calculation completed correctly;

1777

// -I, if the input parameter number I is out of range;

1778

// +1, if the answer appears to be lower than lowest search bound;

1779

// +2, if the answer appears to be higher than greatest search bound;

1780

// +3, if P + Q /= 1;

1781

// +4, if X + Y /= 1.

1782

1783

// Output, double *BOUND, is only defined if STATUS is nonzero.

1784

// If STATUS is negative, then this is the value exceeded by parameter I.

1785

// if STATUS is 1 or 2, this is the search bound that was exceeded.

1786

1787

{

1788

# define tol (1.0e-8)

1789

# define atol (1.0e-50)

1790

# define zero (1.0e-300)

1791

# define inf 1.0e300

1792

# define one 1.0e0

1793

1794

static int K1 = 1;

1795

static double K2 = 0.0e0;

1796

static double K3 = 1.0e0;

1797

static double K8 = 0.5e0;

1798

static double K9 = 5.0e0;

1799

static double fx,xhi,xlo,cum,ccum,xy,pq;

1800

static unsigned long qhi,qleft,qporq;

1801

static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15;

1802

1803

*status = 0;

1804

*bound = 0.0;

1805

1806

// Check arguments

1807

1808

if(!(*which < 1 || *which > 4)) goto S30;

1809

if(!(*which < 1)) goto S10;

1810

*bound = 1.0e0;

1811

goto S20;

1812

S10:

1813

*bound = 4.0e0;

1814

S20:

1815

*status = -1;

1816

return;

1817

S30:

1818

if(*which == 1) goto S70;

1819

1820

// P

1821

1822

if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;

1823

if(!(*p < 0.0e0)) goto S40;

1824

*bound = 0.0e0;

1825

goto S50;

1826

S40:

1827

*bound = 1.0e0;

1828

S50:

1829

*status = -2;

1830

return;

1831

S70:

1832

S60:

1833

if(*which == 1) goto S110;

1834

1835

// Q

1836

1837

if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;

1838

if(!(*q < 0.0e0)) goto S80;

1839

*bound = 0.0e0;

1840

goto S90;

1841

S80:

1842

*bound = 1.0e0;

1843

S90:

1844

*status = -3;

1845

return;

1846

S110:

1847

S100:

1848

if(*which == 2) goto S150;

1849

1850

// X

1851

1852

if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140;

1853

if(!(*x < 0.0e0)) goto S120;

1854

*bound = 0.0e0;

1855

goto S130;

1856

S120:

1857

*bound = 1.0e0;

1858

S130:

1859

*status = -4;

1860

return;

1861

S150:

1862

S140:

1863

if(*which == 2) goto S190;

1864

1865

// Y

1866

1867

if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180;

1868

if(!(*y < 0.0e0)) goto S160;

1869

*bound = 0.0e0;

1870

goto S170;

1871

S160:

1872

*bound = 1.0e0;

1873

S170:

1874

*status = -5;

1875

return;

1876

S190:

1877

S180:

1878

if(*which == 3) goto S210;

1879

1880

// A

1881

1882

if(!(*a <= 0.0e0)) goto S200;

1883

*bound = 0.0e0;

1884

*status = -6;

1885

return;

1886

S210:

1887

S200:

1888

if(*which == 4) goto S230;

1889

1890

// B

1891

1892

if(!(*b <= 0.0e0)) goto S220;

1893

*bound = 0.0e0;

1894

*status = -7;

1895

return;

1896

S230:

1897

S220:

1898

if(*which == 1) goto S270;

1899

1900

// P + Q

1901

1902

pq = *p+*q;

1903

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S260;

1904

if(!(pq < 0.0e0)) goto S240;

1905

*bound = 0.0e0;

1906

goto S250;

1907

S240:

1908

*bound = 1.0e0;

1909

S250:

1910

*status = 3;

1911

return;

1912

S270:

1913

S260:

1914

if(*which == 2) goto S310;

1915

1916

// X + Y

1917

1918

xy = *x+*y;

1919

if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S300;

1920

if(!(xy < 0.0e0)) goto S280;

1921

*bound = 0.0e0;

1922

goto S290;

1923

S280:

1924

*bound = 1.0e0;

1925

S290:

1926

*status = 4;

1927

return;

1928

S310:

1929

S300:

1930

if(!(*which == 1)) qporq = *p <= *q;

1931

1932

// Select the minimum of P or Q

1933

// Calculate ANSWERS

1934

1935

if(1 == *which) {

1936

1937

// Calculating P and Q

1938

1939

cumbet(x,y,a,b,p,q);

1940

*status = 0;

1941

}

1942

else if(2 == *which) {

1943

1944

// Calculating X and Y

1945

1946

T4 = atol;

1947

T5 = tol;

1948

dstzr(&K2,&K3,&T4,&T5);

1949

if(!qporq) goto S340;

1950

*status = 0;

1951

dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);

1952

*y = one-*x;

1953

S320:

1954

if(!(*status == 1)) goto S330;

1955

cumbet(x,y,a,b,&cum,&ccum);

1956

fx = cum-*p;

1957

dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);

1958

*y = one-*x;

1959

goto S320;

1960

S330:

1961

goto S370;

1962

S340:

1963

*status = 0;

1964

dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);

1965

*x = one-*y;

1966

S350:

1967

if(!(*status == 1)) goto S360;

1968

cumbet(x,y,a,b,&cum,&ccum);

1969

fx = ccum-*q;

1970

dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);

1971

*x = one-*y;

1972

goto S350;

1973

S370:

1974

S360:

1975

if(!(*status == -1)) goto S400;

1976

if(!qleft) goto S380;

1977

*status = 1;

1978

*bound = 0.0e0;

1979

goto S390;

1980

S380:

1981

*status = 2;

1982

*bound = 1.0e0;

1983

S400:

1984

S390:

1985

;

1986

}

1987

else if(3 == *which) {

1988

1989

// Computing A

1990

1991

*a = 5.0e0;

1992

T6 = zero;

1993

T7 = inf;

1994

T10 = atol;

1995

T11 = tol;

1996

dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11);

1997

*status = 0;

1998

dinvr(status,a,&fx,&qleft,&qhi);

1999

S410:

2000

if(!(*status == 1)) goto S440;

2001

cumbet(x,y,a,b,&cum,&ccum);

2002

if(!qporq) goto S420;

2003

fx = cum-*p;

2004

goto S430;

2005

S420:

2006

fx = ccum-*q;

2007

S430:

2008

dinvr(status,a,&fx,&qleft,&qhi);

2009

goto S410;

2010

S440:

2011

if(!(*status == -1)) goto S470;

2012

if(!qleft) goto S450;

2013

*status = 1;

2014

*bound = zero;

2015

goto S460;

2016

S450:

2017

*status = 2;

2018

*bound = inf;

2019

S470:

2020

S460:

2021

;

2022

}

2023

else if(4 == *which) {

2024

2025

// Computing B

2026

2027

*b = 5.0e0;

2028

T12 = zero;

2029

T13 = inf;

2030

T14 = atol;

2031

T15 = tol;

2032

dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15);

2033

*status = 0;

2034

dinvr(status,b,&fx,&qleft,&qhi);

2035

S480:

2036

if(!(*status == 1)) goto S510;

2037

cumbet(x,y,a,b,&cum,&ccum);

2038

if(!qporq) goto S490;

2039

fx = cum-*p;

2040

goto S500;

2041

S490:

2042

fx = ccum-*q;

2043

S500:

2044

dinvr(status,b,&fx,&qleft,&qhi);

2045

goto S480;

2046

S510:

2047

if(!(*status == -1)) goto S540;

2048

if(!qleft) goto S520;

2049

*status = 1;

2050

*bound = zero;

2051

goto S530;

2052

S520:

2053

*status = 2;

2054

*bound = inf;

2055

S530:

2056

;

2057

}

2058

S540:

2059

return;

2060

# undef tol

2061

# undef atol

2062

# undef zero

2063

# undef inf

2064

# undef one

2065

}

2066

//****************************************************************************80

2067

2068

void cdfbin ( int *which, double *p, double *q, double *s, double *xn,

2069

double *pr, double *ompr, int *status, double *bound )

2070

2071

//****************************************************************************80

2072

2073

// Purpose:

2074

2075

// CDFBIN evaluates the CDF of the Binomial distribution.

2076

2077

// Discussion:

2078

2079

// This routine calculates any one parameter of the binomial distribution

2080

// given the others.

2081

2082

// The value P of the cumulative distribution function is calculated

2083

// directly.

2084

2085

// Computation of the other parameters involves a seach for a value that

2086

// produces the desired value of P. The search relies on the

2087

// monotonicity of P with respect to the other parameters.

2088

2089

// P is the probablility of S or fewer successes in XN binomial trials,

2090

// each trial having an individual probability of success of PR.

2091

2092

// Modified:

2093

2094

// 09 June 2004

2095

2096

// Reference:

2097

2098

// Milton Abramowitz and Irene Stegun,

2099

// Handbook of Mathematical Functions

2100

// 1966, Formula 26.5.24.

2101

2102

// Parameters:

2103

2104

// Input, int *WHICH, indicates which of argument values is to

2105

// be calculated from the others.

2106

// 1: Calculate P and Q from S, XN, PR and OMPR;

2107

// 2: Calculate S from P, Q, XN, PR and OMPR;

2108

// 3: Calculate XN from P, Q, S, PR and OMPR;

2109

// 4: Calculate PR and OMPR from P, Q, S and XN.

2110

2111

// Input/output, double *P, the cumulation, from 0 to S,

2112

// of the binomial distribution. If P is an input value, it should

2113

// lie in the range [0,1].

2114

2115

// Input/output, double *Q, equal to 1-P. If Q is an input

2116

// value, it should lie in the range [0,1]. If Q is an output value,

2117

// it will lie in the range [0,1].

2118

2119

// Input/output, double *S, the number of successes observed.

2120

// Whether this is an input or output value, it should lie in the

2121

// range [0,XN].

2122

2123

// Input/output, double *XN, the number of binomial trials.

2124

// If this is an input value it should lie in the range: (0, +infinity).

2125

// If it is an output value it will be searched for in the

2126

// range [1.0D-300, 1.0D+300].

2127

2128

// Input/output, double *PR, the probability of success in each

2129

// binomial trial. Whether this is an input or output value, it should

2130

// lie in the range: [0,1].

2131

2132

// Input/output, double *OMPR, equal to 1-PR. Whether this is an

2133

// input or output value, it should lie in the range [0,1]. Also, it should

2134

// be the case that PR + OMPR = 1.

2135

2136

// Output, int *STATUS, reports the status of the computation.

2137

// 0, if the calculation completed correctly;

2138

// -I, if the input parameter number I is out of range;

2139

// +1, if the answer appears to be lower than lowest search bound;

2140

// +2, if the answer appears to be higher than greatest search bound;

2141

// +3, if P + Q /= 1;

2142

// +4, if PR + OMPR /= 1.

2143

2144

// Output, double *BOUND, is only defined if STATUS is nonzero.

2145

// If STATUS is negative, then this is the value exceeded by parameter I.

2146

// if STATUS is 1 or 2, this is the search bound that was exceeded.

2147

2148

{

2149

# define atol (1.0e-50)

2150

# define tol (1.0e-8)

2151

# define zero (1.0e-300)

2152

# define inf 1.0e300

2153

# define one 1.0e0

2154

2155

static int K1 = 1;

2156

static double K2 = 0.0e0;

2157

static double K3 = 0.5e0;

2158

static double K4 = 5.0e0;

2159

static double K11 = 1.0e0;

2160

static double fx,xhi,xlo,cum,ccum,pq,prompr;

2161

static unsigned long qhi,qleft,qporq;

2162

static double T5,T6,T7,T8,T9,T10,T12,T13;

2163

2164

*status = 0;

2165

*bound = 0.0;

2166

2167

// Check arguments

2168

2169

if(!(*which < 1 && *which > 4)) goto S30;

2170

if(!(*which < 1)) goto S10;

2171

*bound = 1.0e0;

2172

goto S20;

2173

S10:

2174

*bound = 4.0e0;

2175

S20:

2176

*status = -1;

2177

return;

2178

S30:

2179

if(*which == 1) goto S70;

2180

2181

// P

2182

2183

if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;

2184

if(!(*p < 0.0e0)) goto S40;

2185

*bound = 0.0e0;

2186

goto S50;

2187

S40:

2188

*bound = 1.0e0;

2189

S50:

2190

*status = -2;

2191

return;

2192

S70:

2193

S60:

2194

if(*which == 1) goto S110;

2195

2196

// Q

2197

2198

if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;

2199

if(!(*q < 0.0e0)) goto S80;

2200

*bound = 0.0e0;

2201

goto S90;

2202

S80:

2203

*bound = 1.0e0;

2204

S90:

2205

*status = -3;

2206

return;

2207

S110:

2208

S100:

2209

if(*which == 3) goto S130;

2210

2211

// XN

2212

2213

if(!(*xn <= 0.0e0)) goto S120;

2214

*bound = 0.0e0;

2215

*status = -5;

2216

return;

2217

S130:

2218

S120:

2219

if(*which == 2) goto S170;

2220

2221

// S

2222

2223

if(!(*s < 0.0e0 || *which != 3 && *s > *xn)) goto S160;

2224

if(!(*s < 0.0e0)) goto S140;

2225

*bound = 0.0e0;

2226

goto S150;

2227

S140:

2228

*bound = *xn;

2229

S150:

2230

*status = -4;

2231

return;

2232

S170:

2233

S160:

2234

if(*which == 4) goto S210;

2235

2236

// PR

2237

2238

if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200;

2239

if(!(*pr < 0.0e0)) goto S180;

2240

*bound = 0.0e0;

2241

goto S190;

2242

S180:

2243

*bound = 1.0e0;

2244

S190:

2245

*status = -6;

2246

return;

2247

S210:

2248

S200:

2249

if(*which == 4) goto S250;

2250

2251

// OMPR

2252

2253

if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240;

2254

if(!(*ompr < 0.0e0)) goto S220;

2255

*bound = 0.0e0;

2256

goto S230;

2257

S220:

2258

*bound = 1.0e0;

2259

S230:

2260

*status = -7;

2261

return;

2262

S250:

2263

S240:

2264

if(*which == 1) goto S290;

2265

2266

// P + Q

2267

2268

pq = *p+*q;

2269

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S280;

2270

if(!(pq < 0.0e0)) goto S260;

2271

*bound = 0.0e0;

2272

goto S270;

2273

S260:

2274

*bound = 1.0e0;

2275

S270:

2276

*status = 3;

2277

return;

2278

S290:

2279

S280:

2280

if(*which == 4) goto S330;

2281

2282

// PR + OMPR

2283

2284

prompr = *pr+*ompr;

2285

if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S320;

2286

if(!(prompr < 0.0e0)) goto S300;

2287

*bound = 0.0e0;

2288

goto S310;

2289

S300:

2290

*bound = 1.0e0;

2291

S310:

2292

*status = 4;

2293

return;

2294

S330:

2295

S320:

2296

if(!(*which == 1)) qporq = *p <= *q;

2297

2298

// Select the minimum of P or Q

2299

// Calculate ANSWERS

2300

2301

if(1 == *which) {

2302

2303

// Calculating P

2304

2305

cumbin(s,xn,pr,ompr,p,q);

2306

*status = 0;

2307

}

2308

else if(2 == *which) {

2309

2310

// Calculating S

2311

2312

*s = 5.0e0;

2313

T5 = atol;

2314

T6 = tol;

2315

dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6);

2316

*status = 0;

2317

dinvr(status,s,&fx,&qleft,&qhi);

2318

S340:

2319

if(!(*status == 1)) goto S370;

2320

cumbin(s,xn,pr,ompr,&cum,&ccum);

2321

if(!qporq) goto S350;

2322

fx = cum-*p;

2323

goto S360;

2324

S350:

2325

fx = ccum-*q;

2326

S360:

2327

dinvr(status,s,&fx,&qleft,&qhi);

2328

goto S340;

2329

S370:

2330

if(!(*status == -1)) goto S400;

2331

if(!qleft) goto S380;

2332

*status = 1;

2333

*bound = 0.0e0;

2334

goto S390;

2335

S380:

2336

*status = 2;

2337

*bound = *xn;

2338

S400:

2339

S390:

2340

;

2341

}

2342

else if(3 == *which) {

2343

2344

// Calculating XN

2345

2346

*xn = 5.0e0;

2347

T7 = zero;

2348

T8 = inf;

2349

T9 = atol;

2350

T10 = tol;

2351

dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);

2352

*status = 0;

2353

dinvr(status,xn,&fx,&qleft,&qhi);

2354

S410:

2355

if(!(*status == 1)) goto S440;

2356

cumbin(s,xn,pr,ompr,&cum,&ccum);

2357

if(!qporq) goto S420;

2358

fx = cum-*p;

2359

goto S430;

2360

S420:

2361

fx = ccum-*q;

2362

S430:

2363

dinvr(status,xn,&fx,&qleft,&qhi);

2364

goto S410;

2365

S440:

2366

if(!(*status == -1)) goto S470;

2367

if(!qleft) goto S450;

2368

*status = 1;

2369

*bound = zero;

2370

goto S460;

2371

S450:

2372

*status = 2;

2373

*bound = inf;

2374

S470:

2375

S460:

2376

;

2377

}

2378

else if(4 == *which) {

2379

2380

// Calculating PR and OMPR

2381

2382

T12 = atol;

2383

T13 = tol;

2384

dstzr(&K2,&K11,&T12,&T13);

2385

if(!qporq) goto S500;

2386

*status = 0;

2387

dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);

2388

*ompr = one-*pr;

2389

S480:

2390

if(!(*status == 1)) goto S490;

2391

cumbin(s,xn,pr,ompr,&cum,&ccum);

2392

fx = cum-*p;

2393

dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);

2394

*ompr = one-*pr;

2395

goto S480;

2396

S490:

2397

goto S530;

2398

S500:

2399

*status = 0;

2400

dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);

2401

*pr = one-*ompr;

2402

S510:

2403

if(!(*status == 1)) goto S520;

2404

cumbin(s,xn,pr,ompr,&cum,&ccum);

2405

fx = ccum-*q;

2406

dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);

2407

*pr = one-*ompr;

2408

goto S510;

2409

S530:

2410

S520:

2411

if(!(*status == -1)) goto S560;

2412

if(!qleft) goto S540;

2413

*status = 1;

2414

*bound = 0.0e0;

2415

goto S550;

2416

S540:

2417

*status = 2;

2418

*bound = 1.0e0;

2419

S550:

2420

;

2421

}

2422

S560:

2423

return;

2424

# undef atol

2425

# undef tol

2426

# undef zero

2427

# undef inf

2428

# undef one

2429

}

2430

//****************************************************************************80

2431

2432

void cdfchi ( int *which, double *p, double *q, double *x, double *df,

2433

int *status, double *bound )

2434

2435

//****************************************************************************80

2436

2437

// Purpose:

2438

2439

// CDFCHI evaluates the CDF of the chi square distribution.

2440

2441

// Discussion:

2442

2443

// This routine calculates any one parameter of the chi square distribution

2444

// given the others.

2445

2446

// The value P of the cumulative distribution function is calculated

2447

// directly.

2448

2449

// Computation of the other parameters involves a seach for a value that

2450

// produces the desired value of P. The search relies on the

2451

// monotonicity of P with respect to the other parameters.

2452

2453

// The CDF of the chi square distribution can be evaluated

2454

// within Mathematica by commands such as:

2455

2456

// Needs["Statistics`ContinuousDistributions`"]

2457

// CDF [ ChiSquareDistribution [ DF ], X ]

2458

2459

// Reference:

2460

2461

// Milton Abramowitz and Irene Stegun,

2462

// Handbook of Mathematical Functions

2463

// 1966, Formula 26.4.19.

2464

2465

// Stephen Wolfram,

2466

// The Mathematica Book,

2467

// Fourth Edition,

2468

// Wolfram Media / Cambridge University Press, 1999.

2469

2470

// Parameters:

2471

2472

// Input, int *WHICH, indicates which argument is to be calculated

2473

// from the others.

2474

// 1: Calculate P and Q from X and DF;

2475

// 2: Calculate X from P, Q and DF;

2476

// 3: Calculate DF from P, Q and X.

2477

2478

// Input/output, double *P, the integral from 0 to X of

2479

// the chi-square distribution. If this is an input value, it should

2480

// lie in the range [0,1].

2481

2482

// Input/output, double *Q, equal to 1-P. If Q is an input

2483

// value, it should lie in the range [0,1]. If Q is an output value,

2484

// it will lie in the range [0,1].

2485

2486

// Input/output, double *X, the upper limit of integration

2487

// of the chi-square distribution. If this is an input

2488

// value, it should lie in the range: [0, +infinity). If it is an output

2489

// value, it will be searched for in the range: [0,1.0D+300].

2490

2491

// Input/output, double *DF, the degrees of freedom of the

2492

// chi-square distribution. If this is an input value, it should lie

2493

// in the range: (0, +infinity). If it is an output value, it will be

2494

// searched for in the range: [ 1.0D-300, 1.0D+300].

2495

2496

// Output, int *STATUS, reports the status of the computation.

2497

// 0, if the calculation completed correctly;

2498

// -I, if the input parameter number I is out of range;

2499

// +1, if the answer appears to be lower than lowest search bound;

2500

// +2, if the answer appears to be higher than greatest search bound;

2501

// +3, if P + Q /= 1;

2502

// +10, an error was returned from CUMGAM.

2503

2504

// Output, double *BOUND, is only defined if STATUS is nonzero.

2505

// If STATUS is negative, then this is the value exceeded by parameter I.

2506

// if STATUS is 1 or 2, this is the search bound that was exceeded.

2507

2508

{

2509

# define tol (1.0e-8)

2510

# define atol (1.0e-50)

2511

# define zero (1.0e-300)

2512

# define inf 1.0e300

2513

2514

static int K1 = 1;

2515

static double K2 = 0.0e0;

2516

static double K4 = 0.5e0;

2517

static double K5 = 5.0e0;

2518

static double fx,cum,ccum,pq,porq;

2519

static unsigned long qhi,qleft,qporq;

2520

static double T3,T6,T7,T8,T9,T10,T11;

2521

2522

*status = 0;

2523

*bound = 0.0;

2524

2525

// Check arguments

2526

2527

if(!(*which < 1 || *which > 3)) goto S30;

2528

if(!(*which < 1)) goto S10;

2529

*bound = 1.0e0;

2530

goto S20;

2531

S10:

2532

*bound = 3.0e0;

2533

S20:

2534

*status = -1;

2535

return;

2536

S30:

2537

if(*which == 1) goto S70;

2538

2539

// P

2540

2541

if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;

2542

if(!(*p < 0.0e0)) goto S40;

2543

*bound = 0.0e0;

2544

goto S50;

2545

S40:

2546

*bound = 1.0e0;

2547

S50:

2548

*status = -2;

2549

return;

2550

S70:

2551

S60:

2552

if(*which == 1) goto S110;

2553

2554

// Q

2555

2556

if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;

2557

if(!(*q <= 0.0e0)) goto S80;

2558

*bound = 0.0e0;

2559

goto S90;

2560

S80:

2561

*bound = 1.0e0;

2562

S90:

2563

*status = -3;

2564

return;

2565

S110:

2566

S100:

2567

if(*which == 2) goto S130;

2568

2569

// X

2570

2571

if(!(*x < 0.0e0)) goto S120;

2572

*bound = 0.0e0;

2573

*status = -4;

2574

return;

2575

S130:

2576

S120:

2577

if(*which == 3) goto S150;

2578

2579

// DF

2580

2581

if(!(*df <= 0.0e0)) goto S140;

2582

*bound = 0.0e0;

2583

*status = -5;

2584

return;

2585

S150:

2586

S140:

2587

if(*which == 1) goto S190;

2588

2589

// P + Q

2590

2591

pq = *p+*q;

2592

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S180;

2593

if(!(pq < 0.0e0)) goto S160;

2594

*bound = 0.0e0;

2595

goto S170;

2596

S160:

2597

*bound = 1.0e0;

2598

S170:

2599

*status = 3;

2600

return;

2601

S190:

2602

S180:

2603

if(*which == 1) goto S220;

2604

2605

// Select the minimum of P or Q

2606

2607

qporq = *p <= *q;

2608

if(!qporq) goto S200;

2609

porq = *p;

2610

goto S210;

2611

S200:

2612

porq = *q;

2613

S220:

2614

S210:

2615

2616

// Calculate ANSWERS

2617

2618

if(1 == *which) {

2619

2620

// Calculating P and Q

2621

2622

*status = 0;

2623

cumchi(x,df,p,q);

2624

if(porq > 1.5e0) {

2625

*status = 10;

2626

return;

2627

}

2628

}

2629

else if(2 == *which) {

2630

2631

// Calculating X

2632

2633

*x = 5.0e0;

2634

T3 = inf;

2635

T6 = atol;

2636

T7 = tol;

2637

dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);

2638

*status = 0;

2639

dinvr(status,x,&fx,&qleft,&qhi);

2640

S230:

2641

if(!(*status == 1)) goto S270;

2642

cumchi(x,df,&cum,&ccum);

2643

if(!qporq) goto S240;

2644

fx = cum-*p;

2645

goto S250;

2646

S240:

2647

fx = ccum-*q;

2648

S250:

2649

if(!(fx+porq > 1.5e0)) goto S260;

2650

*status = 10;

2651

return;

2652

S260:

2653

dinvr(status,x,&fx,&qleft,&qhi);

2654

goto S230;

2655

S270:

2656

if(!(*status == -1)) goto S300;

2657

if(!qleft) goto S280;

2658

*status = 1;

2659

*bound = 0.0e0;

2660

goto S290;

2661

S280:

2662

*status = 2;

2663

*bound = inf;

2664

S300:

2665

S290:

2666

;

2667

}

2668

else if(3 == *which) {

2669

2670

// Calculating DF

2671

2672

*df = 5.0e0;

2673

T8 = zero;

2674

T9 = inf;

2675

T10 = atol;

2676

T11 = tol;

2677

dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);

2678

*status = 0;

2679

dinvr(status,df,&fx,&qleft,&qhi);

2680

S310:

2681

if(!(*status == 1)) goto S350;

2682

cumchi(x,df,&cum,&ccum);

2683

if(!qporq) goto S320;

2684

fx = cum-*p;

2685

goto S330;

2686

S320:

2687

fx = ccum-*q;

2688

S330:

2689

if(!(fx+porq > 1.5e0)) goto S340;

2690

*status = 10;

2691

return;

2692

S340:

2693

dinvr(status,df,&fx,&qleft,&qhi);

2694

goto S310;

2695

S350:

2696

if(!(*status == -1)) goto S380;

2697

if(!qleft) goto S360;

2698

*status = 1;

2699

*bound = zero;

2700

goto S370;

2701

S360:

2702

*status = 2;

2703

*bound = inf;

2704

S370:

2705

;

2706

}

2707

S380:

2708

return;

2709

# undef tol

2710

# undef atol

2711

# undef zero

2712

# undef inf

2713

}

2714

//****************************************************************************80

2715

2716

void cdfchn ( int *which, double *p, double *q, double *x, double *df,

2717

double *pnonc, int *status, double *bound )

2718

2719

//****************************************************************************80

2720

2721

// Purpose:

2722

2723

// CDFCHN evaluates the CDF of the Noncentral Chi-Square.

2724

2725

// Discussion:

2726

2727

// This routine calculates any one parameter of the noncentral chi-square

2728

// distribution given values for the others.

2729

2730

// The value P of the cumulative distribution function is calculated

2731

// directly.

2732

2733

// Computation of the other parameters involves a seach for a value that

2734

// produces the desired value of P. The search relies on the

2735

// monotonicity of P with respect to the other parameters.

2736

2737

// The computation time required for this routine is proportional

2738

// to the noncentrality parameter (PNONC). Very large values of

2739

// this parameter can consume immense computer resources. This is

2740

// why the search range is bounded by 10,000.

2741

2742

// The CDF of the noncentral chi square distribution can be evaluated

2743

// within Mathematica by commands such as:

2744

2745

// Needs["Statistics`ContinuousDistributions`"]

2746

// CDF[ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]

2747

2748

// Reference:

2749

2750

// Milton Abramowitz and Irene Stegun,

2751

// Handbook of Mathematical Functions

2752

// 1966, Formula 26.5.25.

2753

2754

// Stephen Wolfram,

2755

// The Mathematica Book,

2756

// Fourth Edition,

2757

// Wolfram Media / Cambridge University Press, 1999.

2758

2759

// Parameters:

2760

2761

// Input, int *WHICH, indicates which argument is to be calculated

2762

// from the others.

2763

// 1: Calculate P and Q from X, DF and PNONC;

2764

// 2: Calculate X from P, DF and PNONC;

2765

// 3: Calculate DF from P, X and PNONC;

2766

// 4: Calculate PNONC from P, X and DF.

2767

2768

// Input/output, double *P, the integral from 0 to X of

2769

// the noncentral chi-square distribution. If this is an input

2770

// value, it should lie in the range: [0, 1.0-1.0D-16).

2771

2772

// Input/output, double *Q, is generally not used by this

2773

// subroutine and is only included for similarity with other routines.

2774

// However, if P is to be computed, then a value will also be computed

2775

// for Q.

2776

2777

// Input, double *X, the upper limit of integration of the

2778

// noncentral chi-square distribution. If this is an input value, it

2779

// should lie in the range: [0, +infinity). If it is an output value,

2780

// it will be sought in the range: [0,1.0D+300].

2781

2782

// Input/output, double *DF, the number of degrees of freedom

2783

// of the noncentral chi-square distribution. If this is an input value,

2784

// it should lie in the range: (0, +infinity). If it is an output value,

2785

// it will be searched for in the range: [ 1.0D-300, 1.0D+300].

2786

2787

// Input/output, double *PNONC, the noncentrality parameter of

2788

// the noncentral chi-square distribution. If this is an input value, it

2789

// should lie in the range: [0, +infinity). If it is an output value,

2790

// it will be searched for in the range: [0,1.0D+4]

2791

2792

// Output, int *STATUS, reports on the calculation.

2793

// 0, if calculation completed correctly;

2794

// -I, if input parameter number I is out of range;

2795

// 1, if the answer appears to be lower than the lowest search bound;

2796

// 2, if the answer appears to be higher than the greatest search bound.

2797

2798

// Output, double *BOUND, is only defined if STATUS is nonzero.

2799

// If STATUS is negative, then this is the value exceeded by parameter I.

2800

// if STATUS is 1 or 2, this is the search bound that was exceeded.

2801

2802

{

2803

# define tent4 1.0e4

2804

# define tol (1.0e-8)

2805

# define atol (1.0e-50)

2806

# define zero (1.0e-300)

2807

# define one (1.0e0-1.0e-16)

2808

# define inf 1.0e300

2809

2810

static double K1 = 0.0e0;

2811

static double K3 = 0.5e0;

2812

static double K4 = 5.0e0;

2813

static double fx,cum,ccum;

2814

static unsigned long qhi,qleft;

2815

static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13;

2816

2817

*status = 0;

2818

*bound = 0.0;

2819

2820

// Check arguments

2821

2822

if(!(*which < 1 || *which > 4)) goto S30;

2823

if(!(*which < 1)) goto S10;

2824

*bound = 1.0e0;

2825

goto S20;

2826

S10:

2827

*bound = 4.0e0;

2828

S20:

2829

*status = -1;

2830

return;

2831

S30:

2832

if(*which == 1) goto S70;

2833

2834

// P

2835

2836

if(!(*p < 0.0e0 || *p > one)) goto S60;

2837

if(!(*p < 0.0e0)) goto S40;

2838

*bound = 0.0e0;

2839

goto S50;

2840

S40:

2841

*bound = one;

2842

S50:

2843

*status = -2;

2844

return;

2845

S70:

2846

S60:

2847

if(*which == 2) goto S90;

2848

2849

// X

2850

2851

if(!(*x < 0.0e0)) goto S80;

2852

*bound = 0.0e0;

2853

*status = -4;

2854

return;

2855

S90:

2856

S80:

2857

if(*which == 3) goto S110;

2858

2859

// DF

2860

2861

if(!(*df <= 0.0e0)) goto S100;

2862

*bound = 0.0e0;

2863

*status = -5;

2864

return;

2865

S110:

2866

S100:

2867

if(*which == 4) goto S130;

2868

2869

// PNONC

2870

2871

if(!(*pnonc < 0.0e0)) goto S120;

2872

*bound = 0.0e0;

2873

*status = -6;

2874

return;

2875

S130:

2876

S120:

2877

2878

// Calculate ANSWERS

2879

2880

if(1 == *which) {

2881

2882

// Calculating P and Q

2883

2884

cumchn(x,df,pnonc,p,q);

2885

*status = 0;

2886

}

2887

else if(2 == *which) {

2888

2889

// Calculating X

2890

2891

*x = 5.0e0;

2892

T2 = inf;

2893

T5 = atol;

2894

T6 = tol;

2895

dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);

2896

*status = 0;

2897

dinvr(status,x,&fx,&qleft,&qhi);

2898

S140:

2899

if(!(*status == 1)) goto S150;

2900

cumchn(x,df,pnonc,&cum,&ccum);

2901

fx = cum-*p;

2902

dinvr(status,x,&fx,&qleft,&qhi);

2903

goto S140;

2904

S150:

2905

if(!(*status == -1)) goto S180;

2906

if(!qleft) goto S160;

2907

*status = 1;

2908

*bound = 0.0e0;

2909

goto S170;

2910

S160:

2911

*status = 2;

2912

*bound = inf;

2913

S180:

2914

S170:

2915

;

2916

}

2917

else if(3 == *which) {

2918

2919

// Calculating DF

2920

2921

*df = 5.0e0;

2922

T7 = zero;

2923

T8 = inf;

2924

T9 = atol;

2925

T10 = tol;

2926

dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);

2927

*status = 0;

2928

dinvr(status,df,&fx,&qleft,&qhi);

2929

S190:

2930

if(!(*status == 1)) goto S200;

2931

cumchn(x,df,pnonc,&cum,&ccum);

2932

fx = cum-*p;

2933

dinvr(status,df,&fx,&qleft,&qhi);

2934

goto S190;

2935

S200:

2936

if(!(*status == -1)) goto S230;

2937

if(!qleft) goto S210;

2938

*status = 1;

2939

*bound = zero;

2940

goto S220;

2941

S210:

2942

*status = 2;

2943

*bound = inf;

2944

S230:

2945

S220:

2946

;

2947

}

2948

else if(4 == *which) {

2949

2950

// Calculating PNONC

2951

2952

*pnonc = 5.0e0;

2953

T11 = tent4;

2954

T12 = atol;

2955

T13 = tol;

2956

dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13);

2957

*status = 0;

2958

dinvr(status,pnonc,&fx,&qleft,&qhi);

2959

S240:

2960

if(!(*status == 1)) goto S250;

2961

cumchn(x,df,pnonc,&cum,&ccum);

2962

fx = cum-*p;

2963

dinvr(status,pnonc,&fx,&qleft,&qhi);

2964

goto S240;

2965

S250:

2966

if(!(*status == -1)) goto S280;

2967

if(!qleft) goto S260;

2968

*status = 1;

2969

*bound = zero;

2970

goto S270;

2971

S260:

2972

*status = 2;

2973

*bound = tent4;

2974

S270:

2975

;

2976

}

2977

S280:

2978

return;

2979

# undef tent4

2980

# undef tol

2981

# undef atol

2982

# undef zero

2983

# undef one

2984

# undef inf

2985

}

2986

//****************************************************************************80

2987

2988

void cdff ( int *which, double *p, double *q, double *f, double *dfn,

2989

double *dfd, int *status, double *bound )

2990

2991

//****************************************************************************80

2992

2993

// Purpose:

2994

2995

// CDFF evaluates the CDF of the F distribution.

2996

2997

// Discussion:

2998

2999

// This routine calculates any one parameter of the F distribution

3000

// given the others.

3001

3002

// The value P of the cumulative distribution function is calculated

3003

// directly.

3004

3005

// Computation of the other parameters involves a seach for a value that

3006

// produces the desired value of P. The search relies on the

3007

// monotonicity of P with respect to the other parameters.

3008

3009

// The value of the cumulative F distribution is not necessarily

3010

// monotone in either degree of freedom. There thus may be two

3011

// values that provide a given CDF value. This routine assumes

3012

// monotonicity and will find an arbitrary one of the two values.

3013

3014

// Modified:

3015

3016

// 14 April 2007

3017

3018

// Reference:

3019

3020

// Milton Abramowitz, Irene Stegun,

3021

// Handbook of Mathematical Functions

3022

// 1966, Formula 26.6.2.

3023

3024

// Parameters:

3025

3026

// Input, int *WHICH, indicates which argument is to be calculated

3027

// from the others.

3028

// 1: Calculate P and Q from F, DFN and DFD;

3029

// 2: Calculate F from P, Q, DFN and DFD;

3030

// 3: Calculate DFN from P, Q, F and DFD;

3031

// 4: Calculate DFD from P, Q, F and DFN.

3032

3033

// Input/output, double *P, the integral from 0 to F of

3034

// the F-density. If it is an input value, it should lie in the

3035

// range [0,1].

3036

3037

// Input/output, double *Q, equal to 1-P. If Q is an input

3038

// value, it should lie in the range [0,1]. If Q is an output value,

3039

// it will lie in the range [0,1].

3040

3041

// Input/output, double *F, the upper limit of integration

3042

// of the F-density. If this is an input value, it should lie in the

3043

// range [0, +infinity). If it is an output value, it will be searched

3044

// for in the range [0,1.0D+300].

3045

3046

// Input/output, double *DFN, the number of degrees of

3047

// freedom of the numerator sum of squares. If this is an input value,

3048

// it should lie in the range: (0, +infinity). If it is an output value,

3049

// it will be searched for in the range: [ 1.0D-300, 1.0D+300].

3050

3051

// Input/output, double *DFD, the number of degrees of freedom

3052

// of the denominator sum of squares. If this is an input value, it should

3053

// lie in the range: (0, +infinity). If it is an output value, it will

3054

// be searched for in the range: [ 1.0D-300, 1.0D+300].

3055

3056

// Output, int *STATUS, reports the status of the computation.

3057

// 0, if the calculation completed correctly;

3058

// -I, if the input parameter number I is out of range;

3059

// +1, if the answer appears to be lower than lowest search bound;

3060

// +2, if the answer appears to be higher than greatest search bound;

3061

// +3, if P + Q /= 1.

3062

3063

// Output, double *BOUND, is only defined if STATUS is nonzero.

3064

// If STATUS is negative, then this is the value exceeded by parameter I.

3065

// if STATUS is 1 or 2, this is the search bound that was exceeded.

3066

3067

{

3068

# define tol (1.0e-8)

3069

# define atol (1.0e-50)

3070

# define zero (1.0e-300)

3071

# define inf 1.0e300

3072

3073

static int K1 = 1;

3074

static double K2 = 0.0e0;

3075

static double K4 = 0.5e0;

3076

static double K5 = 5.0e0;

3077

static double pq,fx,cum,ccum;

3078

static unsigned long qhi,qleft,qporq;

3079

static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15;

3080

3081

*status = 0;

3082

*bound = 0.0;

3083

3084

// Check arguments

3085

3086

if(!(*which < 1 || *which > 4)) goto S30;

3087

if(!(*which < 1)) goto S10;

3088

*bound = 1.0e0;

3089

goto S20;

3090

S10:

3091

*bound = 4.0e0;

3092

S20:

3093

*status = -1;

3094

return;

3095

S30:

3096

if(*which == 1) goto S70;

3097

3098

// P

3099

3100

if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;

3101

if(!(*p < 0.0e0)) goto S40;

3102

*bound = 0.0e0;

3103

goto S50;

3104

S40:

3105

*bound = 1.0e0;

3106

S50:

3107

*status = -2;

3108

return;

3109

S70:

3110

S60:

3111

if(*which == 1) goto S110;

3112

3113

// Q

3114

3115

if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;

3116

if(!(*q <= 0.0e0)) goto S80;

3117

*bound = 0.0e0;

3118

goto S90;

3119

S80:

3120

*bound = 1.0e0;

3121

S90:

3122

*status = -3;

3123

return;

3124

S110:

3125

S100:

3126

if(*which == 2) goto S130;

3127

3128

// F

3129

3130

if(!(*f < 0.0e0)) goto S120;

3131

*bound = 0.0e0;

3132

*status = -4;

3133

return;

3134

S130:

3135

S120:

3136

if(*which == 3) goto S150;

3137

3138

// DFN

3139

3140

if(!(*dfn <= 0.0e0)) goto S140;

3141

*bound = 0.0e0;

3142

*status = -5;

3143

return;

3144

S150:

3145

S140:

3146

if(*which == 4) goto S170;

3147

3148

// DFD

3149

3150

if(!(*dfd <= 0.0e0)) goto S160;

3151

*bound = 0.0e0;

3152

*status = -6;

3153

return;

3154

S170:

3155

S160:

3156

if(*which == 1) goto S210;

3157

3158

// P + Q

3159

3160

pq = *p+*q;

3161

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S200;

3162

if(!(pq < 0.0e0)) goto S180;

3163

*bound = 0.0e0;

3164

goto S190;

3165

S180:

3166

*bound = 1.0e0;

3167

S190:

3168

*status = 3;

3169

return;

3170

S210:

3171

S200:

3172

if(!(*which == 1)) qporq = *p <= *q;

3173

3174

// Select the minimum of P or Q

3175

// Calculate ANSWERS

3176

3177

if(1 == *which) {

3178

3179

// Calculating P

3180

3181

cumf(f,dfn,dfd,p,q);

3182

*status = 0;

3183

}

3184

else if(2 == *which) {

3185

3186

// Calculating F

3187

3188

*f = 5.0e0;

3189

T3 = inf;

3190

T6 = atol;

3191

T7 = tol;

3192

dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);

3193

*status = 0;

3194

dinvr(status,f,&fx,&qleft,&qhi);

3195

S220:

3196

if(!(*status == 1)) goto S250;

3197

cumf(f,dfn,dfd,&cum,&ccum);

3198

if(!qporq) goto S230;

3199

fx = cum-*p;

3200

goto S240;

3201

S230:

3202

fx = ccum-*q;

3203

S240:

3204

dinvr(status,f,&fx,&qleft,&qhi);

3205

goto S220;

3206

S250:

3207

if(!(*status == -1)) goto S280;

3208

if(!qleft) goto S260;

3209

*status = 1;

3210

*bound = 0.0e0;

3211

goto S270;

3212

S260:

3213

*status = 2;

3214

*bound = inf;

3215

S280:

3216

S270:

3217

;

3218

}

3219

3220

// Calculate DFN.

3221

3222

// Note that, in the original calculation, the lower bound for DFN was 0.

3223

// Using DFN = 0 causes an error in CUMF when it calls BETA_INC.

3224

// The lower bound was set to the more reasonable value of 1.

3225

// JVB, 14 April 2007.

3226

3227

else if ( 3 == *which )

3228

{

3229

3230

T8 = 1.0;

3231

T9 = inf;

3232

T10 = atol;

3233

T11 = tol;

3234

dstinv ( &T8, &T9, &K4, &K4, &K5, &T10, &T11 );

3235

3236

*status = 0;

3237

*dfn = 5.0;

3238

fx = 0.0;

3239

3240

dinvr ( status, dfn, &fx, &qleft, &qhi );

3241

3242

while ( *status == 1 )

3243

{

3244

cumf ( f, dfn, dfd, &cum, &ccum );

3245

3246

if ( *p <= *q )

3247

{

3248

fx = cum - *p;

3249

}

3250

else

3251

{

3252

fx = ccum - *q;

3253

}

3254

dinvr ( status, dfn, &fx, &qleft, &qhi );

3255

}

3256

3257

if ( *status == -1 )

3258

{

3259

if ( qleft )

3260

{

3261

*status = 1;

3262

*bound = 1.0;

3263

}

3264

else

3265

{

3266

*status = 2;

3267

*bound = inf;

3268

}

3269

}

3270

}

3271

3272

// Calculate DFD.

3273

3274

// Note that, in the original calculation, the lower bound for DFD was 0.

3275

// Using DFD = 0 causes an error in CUMF when it calls BETA_INC.

3276

// The lower bound was set to the more reasonable value of 1.

3277

// JVB, 14 April 2007.

3278

3279

3280

else if ( 4 == *which )

3281

{

3282

3283

T12 = 1.0;

3284

T13 = inf;

3285

T14 = atol;

3286

T15 = tol;

3287

dstinv ( &T12, &T13, &K4, &K4, &K5, &T14, &T15 );

3288

3289

*status = 0;

3290

*dfd = 5.0;

3291

fx = 0.0;

3292

dinvr ( status, dfd, &fx, &qleft, &qhi );

3293

3294

while ( *status == 1 )

3295

{

3296

cumf ( f, dfn, dfd, &cum, &ccum );

3297

3298

if ( *p <= *q )

3299

{

3300

fx = cum - *p;

3301

}

3302

else

3303

{

3304

fx = ccum - *q;

3305

}

3306

dinvr ( status, dfd, &fx, &qleft, &qhi );

3307

}

3308

3309

if ( *status == -1 )

3310

{

3311

if ( qleft )

3312

{

3313

*status = 1;

3314

*bound = 1.0;

3315

}

3316

else

3317

{

3318

*status = 2;

3319

*bound = inf;

3320

}

3321

}

3322

}

3323

3324

return;

3325

# undef tol

3326

# undef atol

3327

# undef zero

3328

# undef inf

3329

}

3330

//****************************************************************************80

3331

3332

void cdffnc ( int *which, double *p, double *q, double *f, double *dfn,

3333

double *dfd, double *phonc, int *status, double *bound )

3334

3335

//****************************************************************************80

3336

3337

// Purpose:

3338

3339

// CDFFNC evaluates the CDF of the Noncentral F distribution.

3340

3341

// Discussion:

3342

3343

// This routine originally used 1.0E+300 as the upper bound for the

3344

// interval in which many of the missing parameters are to be sought.

3345

// Since the underlying rootfinder routine needs to evaluate the

3346

// function at this point, it is no surprise that the program was

3347

// experiencing overflows. A less extravagant upper bound

3348

// is being tried for now!

3349

3350

3351

// This routine calculates any one parameter of the Noncentral F distribution

3352

// given the others.

3353

3354

// The value P of the cumulative distribution function is calculated

3355

// directly.

3356

3357

// Computation of the other parameters involves a seach for a value that

3358

// produces the desired value of P. The search relies on the

3359

// monotonicity of P with respect to the other parameters.

3360

3361

// The computation time required for this routine is proportional

3362

// to the noncentrality parameter PNONC. Very large values of

3363

// this parameter can consume immense computer resources. This is

3364

// why the search range is bounded by 10,000.

3365

3366

// The value of the cumulative noncentral F distribution is not

3367

// necessarily monotone in either degree of freedom. There thus

3368

// may be two values that provide a given CDF value. This routine

3369

// assumes monotonicity and will find an arbitrary one of the two

3370

// values.

3371

3372

// The CDF of the noncentral F distribution can be evaluated

3373

// within Mathematica by commands such as:

3374

3375

// Needs["Statistics`ContinuousDistributions`"]

3376

// CDF [ NoncentralFRatioDistribution [ DFN, DFD, PNONC ], X ]

3377

3378

// Modified:

3379

3380

// 15 June 2004

3381

3382

// Reference:

3383

3384

// Milton Abramowitz and Irene Stegun,

3385

// Handbook of Mathematical Functions

3386

// 1966, Formula 26.6.20.

3387

3388

// Stephen Wolfram,

3389

// The Mathematica Book,

3390

// Fourth Edition,

3391

// Wolfram Media / Cambridge University Press, 1999.

3392

3393

// Parameters:

3394

3395

// Input, int *WHICH, indicates which argument is to be calculated

3396

// from the others.

3397

// 1: Calculate P and Q from F, DFN, DFD and PNONC;

3398

// 2: Calculate F from P, Q, DFN, DFD and PNONC;

3399

// 3: Calculate DFN from P, Q, F, DFD and PNONC;

3400

// 4: Calculate DFD from P, Q, F, DFN and PNONC;

3401

// 5: Calculate PNONC from P, Q, F, DFN and DFD.

3402

3403

// Input/output, double *P, the integral from 0 to F of

3404

// the noncentral F-density. If P is an input value it should

3405

// lie in the range [0,1) (Not including 1!).

3406

3407

// Dummy, double *Q, is not used by this subroutine,

3408

// and is only included for similarity with the other routines.

3409

// Its input value is not checked. If P is to be computed, the

3410

// Q is set to 1 - P.

3411

3412

// Input/output, double *F, the upper limit of integration

3413

// of the noncentral F-density. If this is an input value, it should

3414

// lie in the range: [0, +infinity). If it is an output value, it

3415

// will be searched for in the range: [0,1.0D+30].

3416

3417

// Input/output, double *DFN, the number of degrees of freedom

3418

// of the numerator sum of squares. If this is an input value, it should

3419

// lie in the range: (0, +infinity). If it is an output value, it will

3420

// be searched for in the range: [ 1.0, 1.0D+30].

3421

3422

// Input/output, double *DFD, the number of degrees of freedom

3423

// of the denominator sum of squares. If this is an input value, it should

3424

// be in range: (0, +infinity). If it is an output value, it will be

3425

// searched for in the range [1.0, 1.0D+30].

3426

3427

// Input/output, double *PNONC, the noncentrality parameter

3428

// If this is an input value, it should be nonnegative.

3429

// If it is an output value, it will be searched for in the range: [0,1.0D+4].

3430

3431

// Output, int *STATUS, reports the status of the computation.

3432

// 0, if the calculation completed correctly;

3433

// -I, if the input parameter number I is out of range;

3434

// +1, if the answer appears to be lower than lowest search bound;

3435

// +2, if the answer appears to be higher than greatest search bound;

3436

// +3, if P + Q /= 1.

3437

3438

// Output, double *BOUND, is only defined if STATUS is nonzero.

3439

// If STATUS is negative, then this is the value exceeded by parameter I.

3440

// if STATUS is 1 or 2, this is the search bound that was exceeded.

3441

3442

{

3443

# define tent4 1.0e4

3444

# define tol (1.0e-8)

3445

# define atol (1.0e-50)

3446

# define zero (1.0e-300)

3447

# define one (1.0e0-1.0e-16)

3448

# define inf 1.0e300

3449

3450

static double K1 = 0.0e0;

3451

static double K3 = 0.5e0;

3452

static double K4 = 5.0e0;

3453

static double fx,cum,ccum;

3454

static unsigned long qhi,qleft;

3455

static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17;

3456

3457

*status = 0;

3458

*bound = 0.0;

3459

3460

// Check arguments

3461

3462

if(!(*which < 1 || *which > 5)) goto S30;

3463

if(!(*which < 1)) goto S10;

3464

*bound = 1.0e0;

3465

goto S20;

3466

S10:

3467

*bound = 5.0e0;

3468

S20:

3469

*status = -1;

3470

return;

3471

S30:

3472

if(*which == 1) goto S70;

3473

3474

// P

3475

3476

if(!(*p < 0.0e0 || *p > one)) goto S60;

3477

if(!(*p < 0.0e0)) goto S40;

3478

*bound = 0.0e0;

3479

goto S50;

3480

S40:

3481

*bound = one;

3482

S50:

3483

*status = -2;

3484

return;

3485

S70:

3486

S60:

3487

if(*which == 2) goto S90;

3488

3489

// F

3490

3491

if(!(*f < 0.0e0)) goto S80;

3492

*bound = 0.0e0;

3493

*status = -4;

3494

return;

3495

S90:

3496

S80:

3497

if(*which == 3) goto S110;

3498

3499

// DFN

3500

3501

if(!(*dfn <= 0.0e0)) goto S100;

3502

*bound = 0.0e0;

3503

*status = -5;

3504

return;

3505

S110:

3506

S100:

3507

if(*which == 4) goto S130;

3508

3509

// DFD

3510

3511

if(!(*dfd <= 0.0e0)) goto S120;

3512

*bound = 0.0e0;

3513

*status = -6;

3514

return;

3515

S130:

3516

S120:

3517

if(*which == 5) goto S150;

3518

3519

// PHONC

3520

3521

if(!(*phonc < 0.0e0)) goto S140;

3522

*bound = 0.0e0;

3523

*status = -7;

3524

return;

3525

S150:

3526

S140:

3527

3528

// Calculate ANSWERS

3529

3530

if(1 == *which) {

3531

3532

// Calculating P

3533

3534

cumfnc(f,dfn,dfd,phonc,p,q);

3535

*status = 0;

3536

}

3537

else if(2 == *which) {

3538

3539

// Calculating F

3540

3541

*f = 5.0e0;

3542

T2 = inf;

3543

T5 = atol;

3544

T6 = tol;

3545

dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);

3546

*status = 0;

3547

dinvr(status,f,&fx,&qleft,&qhi);

3548

S160:

3549

if(!(*status == 1)) goto S170;

3550

cumfnc(f,dfn,dfd,phonc,&cum,&ccum);

3551

fx = cum-*p;

3552

dinvr(status,f,&fx,&qleft,&qhi);

3553

goto S160;

3554

S170:

3555

if(!(*status == -1)) goto S200;

3556

if(!qleft) goto S180;

3557

*status = 1;

3558

*bound = 0.0e0;

3559

goto S190;

3560

S180:

3561

*status = 2;

3562

*bound = inf;

3563

S200:

3564

S190:

3565

;

3566

}

3567

else if(3 == *which) {

3568

3569

// Calculating DFN

3570

3571

*dfn = 5.0e0;

3572

T7 = zero;

3573

T8 = inf;

3574

T9 = atol;

3575

T10 = tol;

3576

dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);

3577

*status = 0;

3578

dinvr(status,dfn,&fx,&qleft,&qhi);

3579

S210:

3580

if(!(*status == 1)) goto S220;

3581

cumfnc(f,dfn,dfd,phonc,&cum,&ccum);

3582

fx = cum-*p;

3583

dinvr(status,dfn,&fx,&qleft,&qhi);

3584

goto S210;

3585

S220:

3586

if(!(*status == -1)) goto S250;

3587

if(!qleft) goto S230;

3588

*status = 1;

3589

*bound = zero;

3590

goto S240;

3591

S230:

3592

*status = 2;

3593

*bound = inf;

3594

S250:

3595

S240:

3596

;

3597

}

3598

else if(4 == *which) {

3599

3600

// Calculating DFD

3601

3602

*dfd = 5.0e0;

3603

T11 = zero;

3604

T12 = inf;

3605

T13 = atol;

3606

T14 = tol;

3607

dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14);

3608

*status = 0;

3609

dinvr(status,dfd,&fx,&qleft,&qhi);

3610

S260:

3611

if(!(*status == 1)) goto S270;

3612

cumfnc(f,dfn,dfd,phonc,&cum,&ccum);

3613

fx = cum-*p;

3614

dinvr(status,dfd,&fx,&qleft,&qhi);

3615

goto S260;

3616

S270:

3617

if(!(*status == -1)) goto S300;

3618

if(!qleft) goto S280;

3619

*status = 1;

3620

*bound = zero;

3621

goto S290;

3622

S280:

3623

*status = 2;

3624

*bound = inf;

3625

S300:

3626

S290:

3627

;

3628

}

3629

else if(5 == *which) {

3630

3631

// Calculating PHONC

3632

3633

*phonc = 5.0e0;

3634

T15 = tent4;

3635

T16 = atol;

3636

T17 = tol;

3637

dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17);

3638

*status = 0;

3639

dinvr(status,phonc,&fx,&qleft,&qhi);

3640

S310:

3641

if(!(*status == 1)) goto S320;

3642

cumfnc(f,dfn,dfd,phonc,&cum,&ccum);

3643

fx = cum-*p;

3644

dinvr(status,phonc,&fx,&qleft,&qhi);

3645

goto S310;

3646

S320:

3647

if(!(*status == -1)) goto S350;

3648

if(!qleft) goto S330;

3649

*status = 1;

3650

*bound = 0.0e0;

3651

goto S340;

3652

S330:

3653

*status = 2;

3654

*bound = tent4;

3655

S340:

3656

;

3657

}

3658

S350:

3659

return;

3660

# undef tent4

3661

# undef tol

3662

# undef atol

3663

# undef zero

3664

# undef one

3665

# undef inf

3666

}

3667

//****************************************************************************80

3668

3669

void cdfgam ( int *which, double *p, double *q, double *x, double *shape,

3670

double *scale, int *status, double *bound )

3671

3672

//****************************************************************************80

3673

3674

// Purpose:

3675

3676

// CDFGAM evaluates the CDF of the Gamma Distribution.

3677

3678

// Discussion:

3679

3680

// This routine calculates any one parameter of the Gamma distribution

3681

// given the others.

3682

3683

// The cumulative distribution function P is calculated directly.

3684

3685

// Computation of the other parameters involves a seach for a value that

3686

// produces the desired value of P. The search relies on the

3687

// monotonicity of P with respect to the other parameters.

3688

3689

// The gamma density is proportional to T**(SHAPE - 1) * EXP(- SCALE * T)

3690

3691

// Reference:

3692

3693

// Armido DiDinato and Alfred Morris,

3694

// Computation of the incomplete gamma function ratios and their inverse,

3695

// ACM Transactions on Mathematical Software,

3696

// Volume 12, 1986, pages 377-393.

3697

3698

// Parameters:

3699

3700

// Input, int *WHICH, indicates which argument is to be calculated

3701

// from the others.

3702

// 1: Calculate P and Q from X, SHAPE and SCALE;

3703

// 2: Calculate X from P, Q, SHAPE and SCALE;

3704

// 3: Calculate SHAPE from P, Q, X and SCALE;

3705

// 4: Calculate SCALE from P, Q, X and SHAPE.

3706

3707

// Input/output, double *P, the integral from 0 to X of the

3708

// Gamma density. If this is an input value, it should lie in the

3709

// range: [0,1].

3710

3711

// Input/output, double *Q, equal to 1-P. If Q is an input

3712

// value, it should lie in the range [0,1]. If Q is an output value,

3713

// it will lie in the range [0,1].

3714

3715

// Input/output, double *X, the upper limit of integration of

3716

// the Gamma density. If this is an input value, it should lie in the

3717

// range: [0, +infinity). If it is an output value, it will lie in

3718

// the range: [0,1E300].

3719

3720

// Input/output, double *SHAPE, the shape parameter of the

3721

// Gamma density. If this is an input value, it should lie in the range:

3722

// (0, +infinity). If it is an output value, it will be searched for

3723

// in the range: [1.0D-300,1.0D+300].

3724

3725

// Input/output, double *SCALE, the scale parameter of the

3726

// Gamma density. If this is an input value, it should lie in the range

3727

// (0, +infinity). If it is an output value, it will be searched for

3728

// in the range: (1.0D-300,1.0D+300].

3729

3730

// Output, int *STATUS, reports the status of the computation.

3731

// 0, if the calculation completed correctly;

3732

// -I, if the input parameter number I is out of range;

3733

// +1, if the answer appears to be lower than lowest search bound;

3734

// +2, if the answer appears to be higher than greatest search bound;

3735

// +3, if P + Q /= 1;

3736

// +10, if the Gamma or inverse Gamma routine cannot compute the answer.

3737

// This usually happens only for X and SHAPE very large (more than 1.0D+10.

3738

3739

// Output, double *BOUND, is only defined if STATUS is nonzero.

3740

// If STATUS is negative, then this is the value exceeded by parameter I.

3741

// if STATUS is 1 or 2, this is the search bound that was exceeded.

3742

3743

{

3744

# define tol (1.0e-8)

3745

# define atol (1.0e-50)

3746

# define zero (1.0e-300)

3747

# define inf 1.0e300

3748

3749

static int K1 = 1;

3750

static double K5 = 0.5e0;

3751

static double K6 = 5.0e0;

3752

static double xx,fx,xscale,cum,ccum,pq,porq;

3753

static int ierr;

3754

static unsigned long qhi,qleft,qporq;

3755

static double T2,T3,T4,T7,T8,T9;

3756

3757

*status = 0;

3758

*bound = 0.0;

3759

3760

// Check arguments

3761

3762

if(!(*which < 1 || *which > 4)) goto S30;

3763

if(!(*which < 1)) goto S10;

3764

*bound = 1.0e0;

3765

goto S20;

3766

S10:

3767

*bound = 4.0e0;

3768

S20:

3769

*status = -1;

3770

return;

3771

S30:

3772

if(*which == 1) goto S70;

3773

3774

// P

3775

3776

if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;

3777

if(!(*p < 0.0e0)) goto S40;

3778

*bound = 0.0e0;

3779

goto S50;

3780

S40:

3781

*bound = 1.0e0;

3782

S50:

3783

*status = -2;

3784

return;

3785

S70:

3786

S60:

3787

if(*which == 1) goto S110;

3788

3789

// Q

3790

3791

if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;

3792

if(!(*q <= 0.0e0)) goto S80;

3793

*bound = 0.0e0;

3794

goto S90;

3795

S80:

3796

*bound = 1.0e0;

3797

S90:

3798

*status = -3;

3799

return;

3800

S110:

3801

S100:

3802

if(*which == 2) goto S130;

3803

3804

// X

3805

3806

if(!(*x < 0.0e0)) goto S120;

3807

*bound = 0.0e0;

3808

*status = -4;

3809

return;

3810

S130:

3811

S120:

3812

if(*which == 3) goto S150;

3813

3814

// SHAPE

3815

3816

if(!(*shape <= 0.0e0)) goto S140;

3817

*bound = 0.0e0;

3818

*status = -5;

3819

return;

3820

S150:

3821

S140:

3822

if(*which == 4) goto S170;

3823

3824

// SCALE

3825

3826

if(!(*scale <= 0.0e0)) goto S160;

3827

*bound = 0.0e0;

3828

*status = -6;

3829

return;

3830

S170:

3831

S160:

3832

if(*which == 1) goto S210;

3833

3834

// P + Q

3835

3836

pq = *p+*q;

3837

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S200;

3838

if(!(pq < 0.0e0)) goto S180;

3839

*bound = 0.0e0;

3840

goto S190;

3841

S180:

3842

*bound = 1.0e0;

3843

S190:

3844

*status = 3;

3845

return;

3846

S210:

3847

S200:

3848

if(*which == 1) goto S240;

3849

3850

// Select the minimum of P or Q

3851

3852

qporq = *p <= *q;

3853

if(!qporq) goto S220;

3854

porq = *p;

3855

goto S230;

3856

S220:

3857

porq = *q;

3858

S240:

3859

S230:

3860

3861

// Calculate ANSWERS

3862

3863

if(1 == *which) {

3864

3865

// Calculating P

3866

3867

*status = 0;

3868

xscale = *x**scale;

3869

cumgam(&xscale,shape,p,q);

3870

if(porq > 1.5e0) *status = 10;

3871

}

3872

else if(2 == *which) {

3873

3874

// Computing X

3875

3876

T2 = -1.0e0;

3877

gamma_inc_inv ( shape, &xx, &T2, p, q, &ierr );

3878

if(ierr < 0.0e0) {

3879

*status = 10;

3880

return;

3881

}

3882

else {

3883

*x = xx/ *scale;

3884

*status = 0;

3885

}

3886

}

3887

else if(3 == *which) {

3888

3889

// Computing SHAPE

3890

3891

*shape = 5.0e0;

3892

xscale = *x**scale;

3893

T3 = zero;

3894

T4 = inf;

3895

T7 = atol;

3896

T8 = tol;

3897

dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8);

3898

*status = 0;

3899

dinvr(status,shape,&fx,&qleft,&qhi);

3900

S250:

3901

if(!(*status == 1)) goto S290;

3902

cumgam(&xscale,shape,&cum,&ccum);

3903

if(!qporq) goto S260;

3904

fx = cum-*p;

3905

goto S270;

3906

S260:

3907

fx = ccum-*q;

3908

S270:

3909

if(!(qporq && cum > 1.5e0 || !qporq && ccum > 1.5e0)) goto S280;

3910

*status = 10;

3911

return;

3912

S280:

3913

dinvr(status,shape,&fx,&qleft,&qhi);

3914

goto S250;

3915

S290:

3916

if(!(*status == -1)) goto S320;

3917

if(!qleft) goto S300;

3918

*status = 1;

3919

*bound = zero;

3920

goto S310;

3921

S300:

3922

*status = 2;

3923

*bound = inf;

3924

S320:

3925

S310:

3926

;

3927

}

3928

else if(4 == *which) {

3929

3930

// Computing SCALE

3931

3932

T9 = -1.0e0;

3933

gamma_inc_inv ( shape, &xx, &T9, p, q, &ierr );

3934

if(ierr < 0.0e0) {

3935

*status = 10;

3936

return;

3937

}

3938

else {

3939

*scale = xx/ *x;

3940

*status = 0;

3941

}

3942

}

3943

return;

3944

# undef tol

3945

# undef atol

3946

# undef zero

3947

# undef inf

3948

}

3949

//****************************************************************************80

3950

3951

void cdfnbn ( int *which, double *p, double *q, double *s, double *xn,

3952

double *pr, double *ompr, int *status, double *bound )

3953

3954

//****************************************************************************80

3955

3956

// Purpose:

3957

3958

// CDFNBN evaluates the CDF of the Negative Binomial distribution

3959

3960

// Discussion:

3961

3962

// This routine calculates any one parameter of the negative binomial

3963

// distribution given values for the others.

3964

3965

// The cumulative negative binomial distribution returns the

3966

// probability that there will be F or fewer failures before the

3967

// S-th success in binomial trials each of which has probability of

3968

// success PR.

3969

3970

// The individual term of the negative binomial is the probability of

3971

// F failures before S successes and is

3972

// Choose( F, S+F-1 ) * PR^(S) * (1-PR)^F

3973

3974

// Computation of other parameters involve a seach for a value that

3975

// produces the desired value of P. The search relies on the

3976

// monotonicity of P with respect to the other parameters.

3977

3978

// Reference:

3979

3980

// Milton Abramowitz and Irene Stegun,

3981

// Handbook of Mathematical Functions

3982

// 1966, Formula 26.5.26.

3983

3984

// Parameters:

3985

3986

// Input, int WHICH, indicates which argument is to be calculated

3987

// from the others.

3988

// 1: Calculate P and Q from F, S, PR and OMPR;

3989

// 2: Calculate F from P, Q, S, PR and OMPR;

3990

// 3: Calculate S from P, Q, F, PR and OMPR;

3991

// 4: Calculate PR and OMPR from P, Q, F and S.

3992

3993

// Input/output, double P, the cumulation from 0 to F of

3994

// the negative binomial distribution. If P is an input value, it

3995

// should lie in the range [0,1].

3996

3997

// Input/output, double Q, equal to 1-P. If Q is an input

3998

// value, it should lie in the range [0,1]. If Q is an output value,

3999

// it will lie in the range [0,1].

4000

4001

// Input/output, double F, the upper limit of cumulation of

4002

// the binomial distribution. There are F or fewer failures before

4003

// the S-th success. If this is an input value, it may lie in the

4004

// range [0,+infinity), and if it is an output value, it will be searched

4005

// for in the range [0,1.0D+300].

4006

4007

// Input/output, double S, the number of successes.

4008

// If this is an input value, it should lie in the range: [0, +infinity).

4009

// If it is an output value, it will be searched for in the range:

4010

// [0, 1.0D+300].

4011

4012

// Input/output, double PR, the probability of success in each

4013

// binomial trial. Whether an input or output value, it should lie in the

4014

// range [0,1].

4015

4016

// Input/output, double OMPR, the value of (1-PR). Whether an

4017

// input or output value, it should lie in the range [0,1].

4018

4019

// Output, int STATUS, reports the status of the computation.

4020

// 0, if the calculation completed correctly;

4021

// -I, if the input parameter number I is out of range;

4022

// +1, if the answer appears to be lower than lowest search bound;

4023

// +2, if the answer appears to be higher than greatest search bound;

4024

// +3, if P + Q /= 1;

4025

// +4, if PR + OMPR /= 1.

4026

4027

// Output, double BOUND, is only defined if STATUS is nonzero.

4028

// If STATUS is negative, then this is the value exceeded by parameter I.

4029

// if STATUS is 1 or 2, this is the search bound that was exceeded.

4030

4031

{

4032

# define tol (1.0e-8)

4033

# define atol (1.0e-50)

4034

# define inf 1.0e300

4035

# define one 1.0e0

4036

4037

static int K1 = 1;

4038

static double K2 = 0.0e0;

4039

static double K4 = 0.5e0;

4040

static double K5 = 5.0e0;

4041

static double K11 = 1.0e0;

4042

static double fx,xhi,xlo,pq,prompr,cum,ccum;

4043

static unsigned long qhi,qleft,qporq;

4044

static double T3,T6,T7,T8,T9,T10,T12,T13;

4045

4046

*status = 0;

4047

*bound = 0.0;

4048

4049

// Check arguments

4050

4051

if(!(*which < 1 || *which > 4)) goto S30;

4052

if(!(*which < 1)) goto S10;

4053

*bound = 1.0e0;

4054

goto S20;

4055

S10:

4056

*bound = 4.0e0;

4057

S20:

4058

*status = -1;

4059

return;

4060

S30:

4061

if(*which == 1) goto S70;

4062

4063

// P

4064

4065

if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;

4066

if(!(*p < 0.0e0)) goto S40;

4067

*bound = 0.0e0;

4068

goto S50;

4069

S40:

4070

*bound = 1.0e0;

4071

S50:

4072

*status = -2;

4073

return;

4074

S70:

4075

S60:

4076

if(*which == 1) goto S110;

4077

4078

// Q

4079

4080

if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;

4081

if(!(*q <= 0.0e0)) goto S80;

4082

*bound = 0.0e0;

4083

goto S90;

4084

S80:

4085

*bound = 1.0e0;

4086

S90:

4087

*status = -3;

4088

return;

4089

S110:

4090

S100:

4091

if(*which == 2) goto S130;

4092

4093

// S

4094

4095

if(!(*s < 0.0e0)) goto S120;

4096

*bound = 0.0e0;

4097

*status = -4;

4098

return;

4099

S130:

4100

S120:

4101

if(*which == 3) goto S150;

4102

4103

// XN

4104

4105

if(!(*xn < 0.0e0)) goto S140;

4106

*bound = 0.0e0;

4107

*status = -5;

4108

return;

4109

S150:

4110

S140:

4111

if(*which == 4) goto S190;

4112

4113

// PR

4114

4115

if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180;

4116

if(!(*pr < 0.0e0)) goto S160;

4117

*bound = 0.0e0;

4118

goto S170;

4119

S160:

4120

*bound = 1.0e0;

4121

S170:

4122

*status = -6;

4123

return;

4124

S190:

4125

S180:

4126

if(*which == 4) goto S230;

4127

4128

// OMPR

4129

4130

if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220;

4131

if(!(*ompr < 0.0e0)) goto S200;

4132

*bound = 0.0e0;

4133

goto S210;

4134

S200:

4135

*bound = 1.0e0;

4136

S210:

4137

*status = -7;

4138

return;

4139

S230:

4140

S220:

4141

if(*which == 1) goto S270;

4142

4143

// P + Q

4144

4145

pq = *p+*q;

4146

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S260;

4147

if(!(pq < 0.0e0)) goto S240;

4148

*bound = 0.0e0;

4149

goto S250;

4150

S240:

4151

*bound = 1.0e0;

4152

S250:

4153

*status = 3;

4154

return;

4155

S270:

4156

S260:

4157

if(*which == 4) goto S310;

4158

4159

// PR + OMPR

4160

4161

prompr = *pr+*ompr;

4162

if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S300;

4163

if(!(prompr < 0.0e0)) goto S280;

4164

*bound = 0.0e0;

4165

goto S290;

4166

S280:

4167

*bound = 1.0e0;

4168

S290:

4169

*status = 4;

4170

return;

4171

S310:

4172

S300:

4173

if(!(*which == 1)) qporq = *p <= *q;

4174

4175

// Select the minimum of P or Q

4176

// Calculate ANSWERS

4177

4178

if(1 == *which) {

4179

4180

// Calculating P

4181

4182

cumnbn(s,xn,pr,ompr,p,q);

4183

*status = 0;

4184

}

4185

else if(2 == *which) {

4186

4187

// Calculating S

4188

4189

*s = 5.0e0;

4190

T3 = inf;

4191

T6 = atol;

4192

T7 = tol;

4193

dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);

4194

*status = 0;

4195

dinvr(status,s,&fx,&qleft,&qhi);

4196

S320:

4197

if(!(*status == 1)) goto S350;

4198

cumnbn(s,xn,pr,ompr,&cum,&ccum);

4199

if(!qporq) goto S330;

4200

fx = cum-*p;

4201

goto S340;

4202

S330:

4203

fx = ccum-*q;

4204

S340:

4205

dinvr(status,s,&fx,&qleft,&qhi);

4206

goto S320;

4207

S350:

4208

if(!(*status == -1)) goto S380;

4209

if(!qleft) goto S360;

4210

*status = 1;

4211

*bound = 0.0e0;

4212

goto S370;

4213

S360:

4214

*status = 2;

4215

*bound = inf;

4216

S380:

4217

S370:

4218

;

4219

}

4220

else if(3 == *which) {

4221

4222

// Calculating XN

4223

4224

*xn = 5.0e0;

4225

T8 = inf;

4226

T9 = atol;

4227

T10 = tol;

4228

dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);

4229

*status = 0;

4230

dinvr(status,xn,&fx,&qleft,&qhi);

4231

S390:

4232

if(!(*status == 1)) goto S420;

4233

cumnbn(s,xn,pr,ompr,&cum,&ccum);

4234

if(!qporq) goto S400;

4235

fx = cum-*p;

4236

goto S410;

4237

S400:

4238

fx = ccum-*q;

4239

S410:

4240

dinvr(status,xn,&fx,&qleft,&qhi);

4241

goto S390;

4242

S420:

4243

if(!(*status == -1)) goto S450;

4244

if(!qleft) goto S430;

4245

*status = 1;

4246

*bound = 0.0e0;

4247

goto S440;

4248

S430:

4249

*status = 2;

4250

*bound = inf;

4251

S450:

4252

S440:

4253

;

4254

}

4255

else if(4 == *which) {

4256

4257

// Calculating PR and OMPR

4258

4259

T12 = atol;

4260

T13 = tol;

4261

dstzr(&K2,&K11,&T12,&T13);

4262

if(!qporq) goto S480;

4263

*status = 0;

4264

dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);

4265

*ompr = one-*pr;

4266

S460:

4267

if(!(*status == 1)) goto S470;

4268

cumnbn(s,xn,pr,ompr,&cum,&ccum);

4269

fx = cum-*p;

4270

dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);

4271

*ompr = one-*pr;

4272

goto S460;

4273

S470:

4274

goto S510;

4275

S480:

4276

*status = 0;

4277

dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);

4278

*pr = one-*ompr;

4279

S490:

4280

if(!(*status == 1)) goto S500;

4281

cumnbn(s,xn,pr,ompr,&cum,&ccum);

4282

fx = ccum-*q;

4283

dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);

4284

*pr = one-*ompr;

4285

goto S490;

4286

S510:

4287

S500:

4288

if(!(*status == -1)) goto S540;

4289

if(!qleft) goto S520;

4290

*status = 1;

4291

*bound = 0.0e0;

4292

goto S530;

4293

S520:

4294

*status = 2;

4295

*bound = 1.0e0;

4296

S530:

4297

;

4298

}

4299

S540:

4300

return;

4301

# undef tol

4302

# undef atol

4303

# undef inf

4304

# undef one

4305

}

4306

//****************************************************************************80

4307

4308

void cdfnor ( int *which, double *p, double *q, double *x, double *mean,

4309

double *sd, int *status, double *bound )

4310

4311

//****************************************************************************80

4312

4313

// Purpose:

4314

4315

// CDFNOR evaluates the CDF of the Normal distribution.

4316

4317

// Discussion:

4318

4319

// A slightly modified version of ANORM from SPECFUN

4320

// is used to calculate the cumulative standard normal distribution.

4321

4322

// The rational functions from pages 90-95 of Kennedy and Gentle

4323

// are used as starting values to Newton's Iterations which

4324

// compute the inverse standard normal. Therefore no searches are

4325

// necessary for any parameter.

4326

4327

// For X < -15, the asymptotic expansion for the normal is used as

4328

// the starting value in finding the inverse standard normal.

4329

4330

// The normal density is proportional to

4331

// exp( - 0.5D+00 * (( X - MEAN)/SD)**2)

4332

4333

// Reference:

4334

4335

// Milton Abramowitz and Irene Stegun,

4336

// Handbook of Mathematical Functions

4337

// 1966, Formula 26.2.12.

4338

4339

// William Cody,

4340

// Algorithm 715: SPECFUN - A Portable FORTRAN Package of

4341

// Special Function Routines and Test Drivers,

4342

// ACM Transactions on Mathematical Software,

4343

// Volume 19, pages 22-32, 1993.

4344

4345

// Kennedy and Gentle,

4346

// Statistical Computing,

4347

// Marcel Dekker, NY, 1980,

4348

// QA276.4 K46

4349

4350

// Parameters:

4351

4352

// Input, int *WHICH, indicates which argument is to be calculated

4353

// from the others.

4354

// 1: Calculate P and Q from X, MEAN and SD;

4355

// 2: Calculate X from P, Q, MEAN and SD;

4356

// 3: Calculate MEAN from P, Q, X and SD;

4357

// 4: Calculate SD from P, Q, X and MEAN.

4358

4359

// Input/output, double *P, the integral from -infinity to X

4360

// of the Normal density. If this is an input or output value, it will

4361

// lie in the range [0,1].

4362

4363

// Input/output, double *Q, equal to 1-P. If Q is an input

4364

// value, it should lie in the range [0,1]. If Q is an output value,

4365

// it will lie in the range [0,1].

4366

4367

// Input/output, double *X, the upper limit of integration of

4368

// the Normal density.

4369

4370

// Input/output, double *MEAN, the mean of the Normal density.

4371

4372

// Input/output, double *SD, the standard deviation of the

4373

// Normal density. If this is an input value, it should lie in the

4374

// range (0,+infinity).

4375

4376

// Output, int *STATUS, the status of the calculation.

4377

// 0, if calculation completed correctly;

4378

// -I, if input parameter number I is out of range;

4379

// 1, if answer appears to be lower than lowest search bound;

4380

// 2, if answer appears to be higher than greatest search bound;

4381

// 3, if P + Q /= 1.

4382

4383

// Output, double *BOUND, is only defined if STATUS is nonzero.

4384

// If STATUS is negative, then this is the value exceeded by parameter I.

4385

// if STATUS is 1 or 2, this is the search bound that was exceeded.

4386

4387

{

4388

static int K1 = 1;

4389

static double z,pq;

4390

4391

*status = 0;

4392

*bound = 0.0;

4393

4394

// Check arguments

4395

4396

*status = 0;

4397

if(!(*which < 1 || *which > 4)) goto S30;

4398

if(!(*which < 1)) goto S10;

4399

*bound = 1.0e0;

4400

goto S20;

4401

S10:

4402

*bound = 4.0e0;

4403

S20:

4404

*status = -1;

4405

return;

4406

S30:

4407

if(*which == 1) goto S70;

4408

4409

// P

4410

4411

if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;

4412

if(!(*p <= 0.0e0)) goto S40;

4413

*bound = 0.0e0;

4414

goto S50;

4415

S40:

4416

*bound = 1.0e0;

4417

S50:

4418

*status = -2;

4419

return;

4420

S70:

4421

S60:

4422

if(*which == 1) goto S110;

4423

4424

// Q

4425

4426

if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;

4427

if(!(*q <= 0.0e0)) goto S80;

4428

*bound = 0.0e0;

4429

goto S90;

4430

S80:

4431

*bound = 1.0e0;

4432

S90:

4433

*status = -3;

4434

return;

4435

S110:

4436

S100:

4437

if(*which == 1) goto S150;

4438

4439

// P + Q

4440

4441

pq = *p+*q;

4442

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S140;

4443

if(!(pq < 0.0e0)) goto S120;

4444

*bound = 0.0e0;

4445

goto S130;

4446

S120:

4447

*bound = 1.0e0;

4448

S130:

4449

*status = 3;

4450

return;

4451

S150:

4452

S140:

4453

if(*which == 4) goto S170;

4454

4455

// SD

4456

4457

if(!(*sd <= 0.0e0)) goto S160;

4458

*bound = 0.0e0;

4459

*status = -6;

4460

return;

4461

S170:

4462

S160:

4463

4464

// Calculate ANSWERS

4465

4466

if(1 == *which) {

4467

4468

// Computing P

4469

4470

z = (*x-*mean)/ *sd;

4471

cumnor(&z,p,q);

4472

}

4473

else if(2 == *which) {

4474

4475

// Computing X

4476

4477

z = dinvnr(p,q);

4478

*x = *sd*z+*mean;

4479

}

4480

else if(3 == *which) {

4481

4482

// Computing the MEAN

4483

4484

z = dinvnr(p,q);

4485

*mean = *x-*sd*z;

4486

}

4487

else if(4 == *which) {

4488

4489

// Computing SD

4490

4491

z = dinvnr(p,q);

4492

*sd = (*x-*mean)/z;

4493

}

4494

return;

4495

}

4496

//****************************************************************************80

4497

4498

void cdfpoi ( int *which, double *p, double *q, double *s, double *xlam,

4499

int *status, double *bound )

4500

4501

//****************************************************************************80

4502

4503

// Purpose:

4504

4505

// CDFPOI evaluates the CDF of the Poisson distribution.

4506

4507

// Discussion:

4508

4509

// This routine calculates any one parameter of the Poisson distribution

4510

// given the others.

4511

4512

// The value P of the cumulative distribution function is calculated

4513

// directly.

4514

4515

// Computation of other parameters involve a seach for a value that

4516

// produces the desired value of P. The search relies on the

4517

// monotonicity of P with respect to the other parameters.

4518

4519

// Reference:

4520

4521

// Milton Abramowitz and Irene Stegun,

4522

// Handbook of Mathematical Functions

4523

// 1966, Formula 26.4.21.

4524

4525

// Parameters:

4526

4527

// Input, int *WHICH, indicates which argument is to be calculated

4528

// from the others.

4529

// 1: Calculate P and Q from S and XLAM;

4530

// 2: Calculate A from P, Q and XLAM;

4531

// 3: Calculate XLAM from P, Q and S.

4532

4533

// Input/output, double *P, the cumulation from 0 to S of the

4534

// Poisson density. Whether this is an input or output value, it will

4535

// lie in the range [0,1].

4536

4537

// Input/output, double *Q, equal to 1-P. If Q is an input

4538

// value, it should lie in the range [0,1]. If Q is an output value,

4539

// it will lie in the range [0,1].

4540

4541

// Input/output, double *S, the upper limit of cumulation of

4542

// the Poisson CDF. If this is an input value, it should lie in

4543

// the range: [0, +infinity). If it is an output value, it will be

4544

// searched for in the range: [0,1.0D+300].

4545

4546

// Input/output, double *XLAM, the mean of the Poisson

4547

// distribution. If this is an input value, it should lie in the range

4548

// [0, +infinity). If it is an output value, it will be searched for

4549

// in the range: [0,1E300].

4550

4551

// Output, int *STATUS, reports the status of the computation.

4552

// 0, if the calculation completed correctly;

4553

// -I, if the input parameter number I is out of range;

4554

// +1, if the answer appears to be lower than lowest search bound;

4555

// +2, if the answer appears to be higher than greatest search bound;

4556

// +3, if P + Q /= 1.

4557

4558

// Output, double *BOUND, is only defined if STATUS is nonzero.

4559

// If STATUS is negative, then this is the value exceeded by parameter I.

4560

// if STATUS is 1 or 2, this is the search bound that was exceeded.

4561

4562

{

4563

# define tol (1.0e-8)

4564

# define atol (1.0e-50)

4565

# define inf 1.0e300

4566

4567

static int K1 = 1;

4568

static double K2 = 0.0e0;

4569

static double K4 = 0.5e0;

4570

static double K5 = 5.0e0;

4571

static double fx,cum,ccum,pq;

4572

static unsigned long qhi,qleft,qporq;

4573

static double T3,T6,T7,T8,T9,T10;

4574

4575

*status = 0;

4576

*bound = 0.0;

4577

4578

// Check arguments

4579

4580

if(!(*which < 1 || *which > 3)) goto S30;

4581

if(!(*which < 1)) goto S10;

4582

*bound = 1.0e0;

4583

goto S20;

4584

S10:

4585

*bound = 3.0e0;

4586

S20:

4587

*status = -1;

4588

return;

4589

S30:

4590

if(*which == 1) goto S70;

4591

4592

// P

4593

4594

if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;

4595

if(!(*p < 0.0e0)) goto S40;

4596

*bound = 0.0e0;

4597

goto S50;

4598

S40:

4599

*bound = 1.0e0;

4600

S50:

4601

*status = -2;

4602

return;

4603

S70:

4604

S60:

4605

if(*which == 1) goto S110;

4606

4607

// Q

4608

4609

if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;

4610

if(!(*q <= 0.0e0)) goto S80;

4611

*bound = 0.0e0;

4612

goto S90;

4613

S80:

4614

*bound = 1.0e0;

4615

S90:

4616

*status = -3;

4617

return;

4618

S110:

4619

S100:

4620

if(*which == 2) goto S130;

4621

4622

// S

4623

4624

if(!(*s < 0.0e0)) goto S120;

4625

*bound = 0.0e0;

4626

*status = -4;

4627

return;

4628

S130:

4629

S120:

4630

if(*which == 3) goto S150;

4631

4632

// XLAM

4633

4634

if(!(*xlam < 0.0e0)) goto S140;

4635

*bound = 0.0e0;

4636

*status = -5;

4637

return;

4638

S150:

4639

S140:

4640

if(*which == 1) goto S190;

4641

4642

// P + Q

4643

4644

pq = *p+*q;

4645

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S180;

4646

if(!(pq < 0.0e0)) goto S160;

4647

*bound = 0.0e0;

4648

goto S170;

4649

S160:

4650

*bound = 1.0e0;

4651

S170:

4652

*status = 3;

4653

return;

4654

S190:

4655

S180:

4656

if(!(*which == 1)) qporq = *p <= *q;

4657

4658

// Select the minimum of P or Q

4659

// Calculate ANSWERS

4660

4661

if(1 == *which) {

4662

4663

// Calculating P

4664

4665

cumpoi(s,xlam,p,q);

4666

*status = 0;

4667

}

4668

else if(2 == *which) {

4669

4670

// Calculating S

4671

4672

*s = 5.0e0;

4673

T3 = inf;

4674

T6 = atol;

4675

T7 = tol;

4676

dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);

4677

*status = 0;

4678

dinvr(status,s,&fx,&qleft,&qhi);

4679

S200:

4680

if(!(*status == 1)) goto S230;

4681

cumpoi(s,xlam,&cum,&ccum);

4682

if(!qporq) goto S210;

4683

fx = cum-*p;

4684

goto S220;

4685

S210:

4686

fx = ccum-*q;

4687

S220:

4688

dinvr(status,s,&fx,&qleft,&qhi);

4689

goto S200;

4690

S230:

4691

if(!(*status == -1)) goto S260;

4692

if(!qleft) goto S240;

4693

*status = 1;

4694

*bound = 0.0e0;

4695

goto S250;

4696

S240:

4697

*status = 2;

4698

*bound = inf;

4699

S260:

4700

S250:

4701

;

4702

}

4703

else if(3 == *which) {

4704

4705

// Calculating XLAM

4706

4707

*xlam = 5.0e0;

4708

T8 = inf;

4709

T9 = atol;

4710

T10 = tol;

4711

dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);

4712

*status = 0;

4713

dinvr(status,xlam,&fx,&qleft,&qhi);

4714

S270:

4715

if(!(*status == 1)) goto S300;

4716

cumpoi(s,xlam,&cum,&ccum);

4717

if(!qporq) goto S280;

4718

fx = cum-*p;

4719

goto S290;

4720

S280:

4721

fx = ccum-*q;

4722

S290:

4723

dinvr(status,xlam,&fx,&qleft,&qhi);

4724

goto S270;

4725

S300:

4726

if(!(*status == -1)) goto S330;

4727

if(!qleft) goto S310;

4728

*status = 1;

4729

*bound = 0.0e0;

4730

goto S320;

4731

S310:

4732

*status = 2;

4733

*bound = inf;

4734

S320:

4735

;

4736

}

4737

S330:

4738

return;

4739

# undef tol

4740

# undef atol

4741

# undef inf

4742

}

4743

//****************************************************************************80

4744

4745

void cdft ( int *which, double *p, double *q, double *t, double *df,

4746

int *status, double *bound )

4747

4748

//****************************************************************************80

4749

4750

// Purpose:

4751

4752

// CDFT evaluates the CDF of the T distribution.

4753

4754

// Discussion:

4755

4756

// This routine calculates any one parameter of the T distribution

4757

// given the others.

4758

4759

// The value P of the cumulative distribution function is calculated

4760

// directly.

4761

4762

// Computation of other parameters involve a seach for a value that

4763

// produces the desired value of P. The search relies on the

4764

// monotonicity of P with respect to the other parameters.

4765

4766

// The original version of this routine allowed the search interval

4767

// to extend from -1.0E+300 to +1.0E+300, which is fine until you

4768

// try to evaluate a function at such a point!

4769

4770

// Reference:

4771

4772

// Milton Abramowitz and Irene Stegun,

4773

// Handbook of Mathematical Functions

4774

// 1966, Formula 26.5.27.

4775

4776

// Parameters:

4777

4778

// Input, int *WHICH, indicates which argument is to be calculated

4779

// from the others.

4780

// 1 : Calculate P and Q from T and DF;

4781

// 2 : Calculate T from P, Q and DF;

4782

// 3 : Calculate DF from P, Q and T.

4783

4784

// Input/output, double *P, the integral from -infinity to T of

4785

// the T-density. Whether an input or output value, this will lie in the

4786

// range [0,1].

4787

4788

// Input/output, double *Q, equal to 1-P. If Q is an input

4789

// value, it should lie in the range [0,1]. If Q is an output value,

4790

// it will lie in the range [0,1].

4791

4792

// Input/output, double *T, the upper limit of integration of

4793

// the T-density. If this is an input value, it may have any value.

4794

// It it is an output value, it will be searched for in the range

4795

// [ -1.0D+30, 1.0D+30 ].

4796

4797

// Input/output, double *DF, the number of degrees of freedom

4798

// of the T distribution. If this is an input value, it should lie

4799

// in the range: (0 , +infinity). If it is an output value, it will be

4800

// searched for in the range: [1, 1.0D+10].

4801

4802

// Output, int *STATUS, reports the status of the computation.

4803

// 0, if the calculation completed correctly;

4804

// -I, if the input parameter number I is out of range;

4805

// +1, if the answer appears to be lower than lowest search bound;

4806

// +2, if the answer appears to be higher than greatest search bound;

4807

// +3, if P + Q /= 1.

4808

4809

// Output, double *BOUND, is only defined if STATUS is nonzero.

4810

// If STATUS is negative, then this is the value exceeded by parameter I.

4811

// if STATUS is 1 or 2, this is the search bound that was exceeded.

4812

4813

{

4814

# define tol (1.0e-8)

4815

# define atol (1.0e-50)

4816

# define zero (1.0e-300)

4817

# define inf 1.0e30

4818

# define maxdf 1.0e10

4819

4820

static int K1 = 1;

4821

static double K4 = 0.5e0;

4822

static double K5 = 5.0e0;

4823

static double fx,cum,ccum,pq;

4824

static unsigned long qhi,qleft,qporq;

4825

static double T2,T3,T6,T7,T8,T9,T10,T11;

4826

4827

*status = 0;

4828

*bound = 0.0;

4829

4830

// Check arguments

4831

4832

if(!(*which < 1 || *which > 3)) goto S30;

4833

if(!(*which < 1)) goto S10;

4834

*bound = 1.0e0;

4835

goto S20;

4836

S10:

4837

*bound = 3.0e0;

4838

S20:

4839

*status = -1;

4840

return;

4841

S30:

4842

if(*which == 1) goto S70;

4843

4844

// P

4845

4846

if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;

4847

if(!(*p <= 0.0e0)) goto S40;

4848

*bound = 0.0e0;

4849

goto S50;

4850

S40:

4851

*bound = 1.0e0;

4852

S50:

4853

*status = -2;

4854

return;

4855

S70:

4856

S60:

4857

if(*which == 1) goto S110;

4858

4859

// Q

4860

4861

if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;

4862

if(!(*q <= 0.0e0)) goto S80;

4863

*bound = 0.0e0;

4864

goto S90;

4865

S80:

4866

*bound = 1.0e0;

4867

S90:

4868

*status = -3;

4869

return;

4870

S110:

4871

S100:

4872

if(*which == 3) goto S130;

4873

4874

// DF

4875

4876

if(!(*df <= 0.0e0)) goto S120;

4877

*bound = 0.0e0;

4878

*status = -5;

4879

return;

4880

S130:

4881

S120:

4882

if(*which == 1) goto S170;

4883

4884

// P + Q

4885

4886

pq = *p+*q;

4887

if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S160;

4888

if(!(pq < 0.0e0)) goto S140;

4889

*bound = 0.0e0;

4890

goto S150;

4891

S140:

4892

*bound = 1.0e0;

4893

S150:

4894

*status = 3;

4895

return;

4896

S170:

4897

S160:

4898

if(!(*which == 1)) qporq = *p <= *q;

4899

4900

// Select the minimum of P or Q

4901

// Calculate ANSWERS

4902

4903

if(1 == *which) {

4904

4905

// Computing P and Q

4906

4907

cumt(t,df,p,q);

4908

*status = 0;

4909

}

4910

else if(2 == *which) {

4911

4912

// Computing T

4913

// .. Get initial approximation for T

4914

4915

*t = dt1(p,q,df);

4916

T2 = -inf;

4917

T3 = inf;

4918

T6 = atol;

4919

T7 = tol;

4920

dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7);

4921

*status = 0;

4922

dinvr(status,t,&fx,&qleft,&qhi);

4923

S180:

4924

if(!(*status == 1)) goto S210;

4925

cumt(t,df,&cum,&ccum);

4926

if(!qporq) goto S190;

4927

fx = cum-*p;

4928

goto S200;

4929

S190:

4930

fx = ccum-*q;

4931

S200:

4932

dinvr(status,t,&fx,&qleft,&qhi);

4933

goto S180;

4934

S210:

4935

if(!(*status == -1)) goto S240;

4936

if(!qleft) goto S220;

4937

*status = 1;

4938

*bound = -inf;

4939

goto S230;

4940

S220:

4941

*status = 2;

4942

*bound = inf;

4943

S240:

4944

S230:

4945

;

4946

}

4947

else if(3 == *which) {

4948

4949

// Computing DF

4950

4951

*df = 5.0e0;

4952

T8 = zero;

4953

T9 = maxdf;

4954

T10 = atol;

4955

T11 = tol;

4956

dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);

4957

*status = 0;

4958

dinvr(status,df,&fx,&qleft,&qhi);

4959

S250:

4960

if(!(*status == 1)) goto S280;

4961

cumt(t,df,&cum,&ccum);

4962

if(!qporq) goto S260;

4963

fx = cum-*p;

4964

goto S270;

4965

S260:

4966

fx = ccum-*q;

4967

S270:

4968

dinvr(status,df,&fx,&qleft,&qhi);

4969

goto S250;

4970

S280:

4971

if(!(*status == -1)) goto S310;

4972

if(!qleft) goto S290;

4973

*status = 1;

4974

*bound = zero;

4975

goto S300;

4976

S290:

4977

*status = 2;

4978

*bound = maxdf;

4979

S300:

4980

;

4981

}

4982

S310:

4983

return;

4984

# undef tol

4985

# undef atol

4986

# undef zero

4987

# undef inf

4988

# undef maxdf

4989

}

4990

//****************************************************************************80

4991

4992

void chi_noncentral_cdf_values ( int *n_data, double *x, double *lambda,

4993

int *df, double *cdf )

4994

4995

//****************************************************************************80

4996

4997

// Purpose:

4998

4999

// CHI_NONCENTRAL_CDF_VALUES returns values of the noncentral chi CDF.

5000

5001

// Discussion:

5002

5003

// The CDF of the noncentral chi square distribution can be evaluated

5004

// within Mathematica by commands such as:

5005

5006

// Needs["Statistics`ContinuousDistributions`"]

5007

// CDF [ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]

5008

5009

// Modified:

5010

5011

// 12 June 2004

5012

5013

// Author:

5014

5015

// John Burkardt

5016

5017

// Reference:

5018

5019

// Stephen Wolfram,

5020

// The Mathematica Book,

5021

// Fourth Edition,

5022

// Wolfram Media / Cambridge University Press, 1999.

5023

5024

// Parameters:

5025

5026

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

5027

// first call. On each call, the routine increments N_DATA by 1, and

5028

// returns the corresponding data; when there is no more data, the

5029

// output value of N_DATA will be 0 again.

5030

5031

// Output, double *X, the argument of the function.

5032

5033

// Output, double *LAMBDA, the noncentrality parameter.

5034

5035

// Output, int *DF, the number of degrees of freedom.

5036

5037

// Output, double *CDF, the noncentral chi CDF.

5038

5039

{

5040

# define N_MAX 27

5041

5042

double cdf_vec[N_MAX] = {

5043

0.839944E+00, 0.695906E+00, 0.535088E+00,

5044

0.764784E+00, 0.620644E+00, 0.469167E+00,

5045

0.307088E+00, 0.220382E+00, 0.150025E+00,

5046

0.307116E-02, 0.176398E-02, 0.981679E-03,

5047

0.165175E-01, 0.202342E-03, 0.498448E-06,

5048

0.151325E-01, 0.209041E-02, 0.246502E-03,

5049

0.263684E-01, 0.185798E-01, 0.130574E-01,

5050

0.583804E-01, 0.424978E-01, 0.308214E-01,

5051

0.105788E+00, 0.794084E-01, 0.593201E-01 };

5052

int df_vec[N_MAX] = {

5053

1, 2, 3,

5054

1, 2, 3,

5055

1, 2, 3,

5056

1, 2, 3,

5057

60, 80, 100,

5058

1, 2, 3,

5059

10, 10, 10,

5060

10, 10, 10,

5061

10, 10, 10 };

5062

double lambda_vec[N_MAX] = {

5063

0.5E+00, 0.5E+00, 0.5E+00,

5064

1.0E+00, 1.0E+00, 1.0E+00,

5065

5.0E+00, 5.0E+00, 5.0E+00,

5066

20.0E+00, 20.0E+00, 20.0E+00,

5067

30.0E+00, 30.0E+00, 30.0E+00,

5068

5.0E+00, 5.0E+00, 5.0E+00,

5069

2.0E+00, 3.0E+00, 4.0E+00,

5070

2.0E+00, 3.0E+00, 4.0E+00,

5071

2.0E+00, 3.0E+00, 4.0E+00 };

5072

double x_vec[N_MAX] = {

5073

3.000E+00, 3.000E+00, 3.000E+00,

5074

3.000E+00, 3.000E+00, 3.000E+00,

5075

3.000E+00, 3.000E+00, 3.000E+00,

5076

3.000E+00, 3.000E+00, 3.000E+00,

5077

60.000E+00, 60.000E+00, 60.000E+00,

5078

0.050E+00, 0.050E+00, 0.050E+00,

5079

4.000E+00, 4.000E+00, 4.000E+00,

5080

5.000E+00, 5.000E+00, 5.000E+00,

5081

6.000E+00, 6.000E+00, 6.000E+00 };

5082

5083

if ( *n_data < 0 )

5084

{

5085

*n_data = 0;

5086

}

5087

5088

*n_data = *n_data + 1;

5089

5090

if ( N_MAX < *n_data )

5091

{

5092

*n_data = 0;

5093

*x = 0.0E+00;

5094

*lambda = 0.0E+00;

5095

*df = 0;

5096

*cdf = 0.0E+00;

5097

}

5098

else

5099

{

5100

*x = x_vec[*n_data-1];

5101

*lambda = lambda_vec[*n_data-1];

5102

*df = df_vec[*n_data-1];

5103

*cdf = cdf_vec[*n_data-1];

5104

}

5105

5106

return;

5107

# undef N_MAX

5108

}

5109

//****************************************************************************80

5110

5111

void chi_square_cdf_values ( int *n_data, int *a, double *x, double *fx )

5112

5113

//****************************************************************************80

5114

5115

// Purpose:

5116

5117

// CHI_SQUARE_CDF_VALUES returns some values of the Chi-Square CDF.

5118

5119

// Discussion:

5120

5121

// The value of CHI_CDF ( DF, X ) can be evaluated in Mathematica by

5122

// commands like:

5123

5124

// Needs["Statistics`ContinuousDistributions`"]

5125

// CDF[ChiSquareDistribution[DF], X ]

5126

5127

// Modified:

5128

5129

// 11 June 2004

5130

5131

// Author:

5132

5133

// John Burkardt

5134

5135

// Reference:

5136

5137

// Milton Abramowitz and Irene Stegun,

5138

// Handbook of Mathematical Functions,

5139

// US Department of Commerce, 1964.

5140

5141

// Stephen Wolfram,

5142

// The Mathematica Book,

5143

// Fourth Edition,

5144

// Wolfram Media / Cambridge University Press, 1999.

5145

5146

// Parameters:

5147

5148

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

5149

// first call. On each call, the routine increments N_DATA by 1, and

5150

// returns the corresponding data; when there is no more data, the

5151

// output value of N_DATA will be 0 again.

5152

5153

// Output, int *A, the parameter of the function.

5154

5155

// Output, double *X, the argument of the function.

5156

5157

// Output, double *FX, the value of the function.

5158

5159

{

5160

# define N_MAX 21

5161

5162

int a_vec[N_MAX] = {

5163

1, 2, 1, 2,

5164

1, 2, 3, 4,

5165

1, 2, 3, 4,

5166

5, 3, 3, 3,

5167

3, 3, 10, 10,

5168

10 };

5169

double fx_vec[N_MAX] = {

5170

0.0796557E+00, 0.00498752E+00, 0.112463E+00, 0.00995017E+00,

5171

0.472911E+00, 0.181269E+00, 0.0597575E+00, 0.0175231E+00,

5172

0.682689E+00, 0.393469E+00, 0.198748E+00, 0.090204E+00,

5173

0.0374342E+00, 0.427593E+00, 0.608375E+00, 0.738536E+00,

5174

0.828203E+00, 0.88839E+00, 0.000172116E+00, 0.00365985E+00,

5175

0.0185759E+00 };

5176

double x_vec[N_MAX] = {

5177

0.01E+00, 0.01E+00, 0.02E+00, 0.02E+00,

5178

0.40E+00, 0.40E+00, 0.40E+00, 0.40E+00,

5179

1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,

5180

1.00E+00, 2.00E+00, 3.00E+00, 4.00E+00,

5181

5.00E+00, 6.00E+00, 1.00E+00, 2.00E+00,

5182

3.00E+00 };

5183

5184

if ( *n_data < 0 )

5185

{

5186

*n_data = 0;

5187

}

5188

5189

*n_data = *n_data + 1;

5190

5191

if ( N_MAX < *n_data )

5192

{

5193

*n_data = 0;

5194

*a = 0;

5195

*x = 0.0E+00;

5196

*fx = 0.0E+00;

5197

}

5198

else

5199

{

5200

*a = a_vec[*n_data-1];

5201

*x = x_vec[*n_data-1];

5202

*fx = fx_vec[*n_data-1];

5203

}

5204

return;

5205

# undef N_MAX

5206

}

5207

//****************************************************************************80

5208

5209

void cumbet ( double *x, double *y, double *a, double *b, double *cum,

5210

double *ccum )

5211

5212

//****************************************************************************80

5213

5214

// Purpose:

5215

5216

// CUMBET evaluates the cumulative incomplete beta distribution.

5217

5218

// Discussion:

5219

5220

// This routine calculates the CDF to X of the incomplete beta distribution

5221

// with parameters A and B. This is the integral from 0 to x

5222

// of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)

5223

5224

// Modified:

5225

5226

// 14 March 2006

5227

5228

// Reference:

5229

5230

// A R Didonato and Alfred Morris,

5231

// Algorithm 708:

5232

// Significant Digit Computation of the Incomplete Beta Function Ratios.

5233

// ACM Transactions on Mathematical Software,

5234

// Volume 18, Number 3, September 1992, pages 360-373.

5235

5236

// Parameters:

5237

5238

// Input, double *X, the upper limit of integration.

5239

5240

// Input, double *Y, the value of 1-X.

5241

5242

// Input, double *A, *B, the parameters of the distribution.

5243

5244

// Output, double *CUM, *CCUM, the values of the cumulative

5245

// density function and complementary cumulative density function.

5246

5247

{

5248

static int ierr;

5249

5250

if ( *x <= 0.0 )

5251

{

5252

*cum = 0.0;

5253

*ccum = 1.0;

5254

}

5255

else if ( *y <= 0.0 )

5256

{

5257

*cum = 1.0;

5258

*ccum = 0.0;

5259

}

5260

else

5261

{

5262

beta_inc ( a, b, x, y, cum, ccum, &ierr );

5263

}

5264

return;

5265

}

5266

//****************************************************************************80

5267

5268

void cumbin ( double *s, double *xn, double *pr, double *ompr,

5269

double *cum, double *ccum )

5270

5271

//****************************************************************************80

5272

5273

// Purpose:

5274

5275

// CUMBIN evaluates the cumulative binomial distribution.

5276

5277

// Discussion:

5278

5279

// This routine returns the probability of 0 to S successes in XN binomial

5280

// trials, each of which has a probability of success, PR.

5281

5282

// Modified:

5283

5284

// 14 March 2006

5285

5286

// Reference:

5287

5288

// Milton Abramowitz and Irene Stegun,

5289

// Handbook of Mathematical Functions

5290

// 1966, Formula 26.5.24.

5291

5292

// Parameters:

5293

5294

// Input, double *S, the upper limit of summation.

5295

5296

// Input, double *XN, the number of trials.

5297

5298

// Input, double *PR, the probability of success in one trial.

5299

5300

// Input, double *OMPR, equals ( 1 - PR ).

5301

5302

// Output, double *CUM, the cumulative binomial distribution.

5303

5304

// Output, double *CCUM, the complement of the cumulative

5305

// binomial distribution.

5306

5307

{

5308

static double T1,T2;

5309

5310

if ( *s < *xn )

5311

{

5312

T1 = *s + 1.0;

5313

T2 = *xn - *s;

5314

cumbet ( pr, ompr, &T1, &T2, ccum, cum );

5315

}

5316

else

5317

{

5318

*cum = 1.0;

5319

*ccum = 0.0;

5320

}

5321

return;

5322

}

5323

//****************************************************************************80

5324

5325

void cumchi ( double *x, double *df, double *cum, double *ccum )

5326

5327

//****************************************************************************80

5328

5329

// Purpose:

5330

5331

// CUMCHI evaluates the cumulative chi-square distribution.

5332

5333

// Parameters:

5334

5335

// Input, double *X, the upper limit of integration.

5336

5337

// Input, double *DF, the degrees of freedom of the

5338

// chi-square distribution.

5339

5340

// Output, double *CUM, the cumulative chi-square distribution.

5341

5342

// Output, double *CCUM, the complement of the cumulative

5343

// chi-square distribution.

5344

5345

{

5346

static double a;

5347

static double xx;

5348

5349

a = *df * 0.5;

5350

xx = *x * 0.5;

5351

cumgam ( &xx, &a, cum, ccum );

5352

return;

5353

}

5354

//****************************************************************************80

5355

5356

void cumchn ( double *x, double *df, double *pnonc, double *cum,

5357

double *ccum )

5358

5359

//****************************************************************************80

5360

5361

// Purpose:

5362

5363

// CUMCHN evaluates the cumulative noncentral chi-square distribution.

5364

5365

// Discussion:

5366

5367

// Calculates the cumulative noncentral chi-square

5368

// distribution, i.e., the probability that a random variable

5369

// which follows the noncentral chi-square distribution, with

5370

// noncentrality parameter PNONC and continuous degrees of

5371

// freedom DF, is less than or equal to X.

5372

5373

// Reference:

5374

5375

// Milton Abramowitz and Irene Stegun,

5376

// Handbook of Mathematical Functions

5377

// 1966, Formula 26.4.25.

5378

5379

// Parameters:

5380

5381

// Input, double *X, the upper limit of integration.

5382

5383

// Input, double *DF, the number of degrees of freedom.

5384

5385

// Input, double *PNONC, the noncentrality parameter of

5386

// the noncentral chi-square distribution.

5387

5388

// Output, double *CUM, *CCUM, the CDF and complementary

5389

// CDF of the noncentral chi-square distribution.

5390

5391

// Local Parameters:

5392

5393

// Local, double EPS, the convergence criterion. The sum

5394

// stops when a term is less than EPS*SUM.

5395

5396

// Local, int NTIRED, the maximum number of terms to be evaluated

5397

// in each sum.

5398

5399

// Local, bool QCONV, is TRUE if convergence was achieved, that is,

5400

// the program did not stop on NTIRED criterion.

5401

5402

{

5403

# define dg(i) (*df+2.0e0*(double)(i))

5404

# define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps*sum)

5405

# define qtired(i) (int)((i) > ntired)

5406

5407

static double eps = 1.0e-5;

5408

static int ntired = 1000;

5409

static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum,

5410

sumadj,term,wt,xnonc;

5411

static int i,icent,iterb,iterf;

5412

static double T1,T2,T3;

5413

5414

if(!(*x <= 0.0e0)) goto S10;

5415

*cum = 0.0e0;

5416

*ccum = 1.0e0;

5417

return;

5418

S10:

5419

if(!(*pnonc <= 1.0e-10)) goto S20;

5420

5421

// When non-centrality parameter is (essentially) zero,

5422

// use cumulative chi-square distribution

5423

5424

cumchi(x,df,cum,ccum);

5425

return;

5426

S20:

5427

xnonc = *pnonc/2.0e0;

5428

5429

// The following code calculates the weight, chi-square, and

5430

// adjustment term for the central term in the infinite series.

5431

// The central term is the one in which the poisson weight is

5432

// greatest. The adjustment term is the amount that must

5433

// be subtracted from the chi-square to move up two degrees

5434

// of freedom.

5435

5436

icent = fifidint(xnonc);

5437

if(icent == 0) icent = 1;

5438

chid2 = *x/2.0e0;

5439

5440

// Calculate central weight term

5441

5442

T1 = (double)(icent+1);

5443

lfact = gamma_log ( &T1 );

5444

lcntwt = -xnonc+(double)icent*log(xnonc)-lfact;

5445

centwt = exp(lcntwt);

5446

5447

// Calculate central chi-square

5448

5449

T2 = dg(icent);

5450

cumchi(x,&T2,&pcent,ccum);

5451

5452

// Calculate central adjustment term

5453

5454

dfd2 = dg(icent)/2.0e0;

5455

T3 = 1.0e0+dfd2;

5456

lfact = gamma_log ( &T3 );

5457

lcntaj = dfd2*log(chid2)-chid2-lfact;

5458

centaj = exp(lcntaj);

5459

sum = centwt*pcent;

5460

5461

// Sum backwards from the central term towards zero.

5462

// Quit whenever either

5463

// (1) the zero term is reached, or

5464

// (2) the term gets small relative to the sum, or

5465

// (3) More than NTIRED terms are totaled.

5466

5467

iterb = 0;

5468

sumadj = 0.0e0;

5469

adj = centaj;

5470

wt = centwt;

5471

i = icent;

5472

goto S40;

5473

S30:

5474

if(qtired(iterb) || qsmall(term) || i == 0) goto S50;

5475

S40:

5476

dfd2 = dg(i)/2.0e0;

5477

5478

// Adjust chi-square for two fewer degrees of freedom.

5479

// The adjusted value ends up in PTERM.

5480

5481

adj = adj*dfd2/chid2;

5482

sumadj = sumadj + adj;

5483

pterm = pcent+sumadj;

5484

5485

// Adjust poisson weight for J decreased by one

5486

5487

wt *= ((double)i/xnonc);

5488

term = wt*pterm;

5489

sum = sum + term;

5490

i -= 1;

5491

iterb = iterb + 1;

5492

goto S30;

5493

S50:

5494

iterf = 0;

5495

5496

// Now sum forward from the central term towards infinity.

5497

// Quit when either

5498

// (1) the term gets small relative to the sum, or

5499

// (2) More than NTIRED terms are totaled.

5500

5501

sumadj = adj = centaj;

5502

wt = centwt;

5503

i = icent;

5504

goto S70;

5505

S60:

5506

if(qtired(iterf) || qsmall(term)) goto S80;

5507

S70:

5508

5509

// Update weights for next higher J

5510

5511

wt *= (xnonc/(double)(i+1));

5512

5513

// Calculate PTERM and add term to sum

5514

5515

pterm = pcent-sumadj;

5516

term = wt*pterm;

5517

sum = sum + term;

5518

5519

// Update adjustment term for DF for next iteration

5520

5521

i = i + 1;

5522

dfd2 = dg(i)/2.0e0;

5523

adj = adj*chid2/dfd2;

5524

sumadj = sum + adj;

5525

iterf = iterf + 1;

5526

goto S60;

5527

S80:

5528

*cum = sum;

5529

*ccum = 0.5e0+(0.5e0-*cum);

5530

return;

5531

# undef dg

5532

# undef qsmall

5533

# undef qtired

5534

}

5535

//****************************************************************************80

5536

5537

void cumf ( double *f, double *dfn, double *dfd, double *cum, double *ccum )

5538

5539

//****************************************************************************80

5540

5541

// Purpose:

5542

5543

// CUMF evaluates the cumulative F distribution.

5544

5545

// Discussion:

5546

5547

// CUMF computes the integral from 0 to F of the F density with DFN

5548

// numerator and DFD denominator degrees of freedom.

5549

5550

// Reference:

5551

5552

// Milton Abramowitz and Irene Stegun,

5553

// Handbook of Mathematical Functions

5554

// 1966, Formula 26.5.28.

5555

5556

// Parameters:

5557

5558

// Input, double *F, the upper limit of integration.

5559

5560

// Input, double *DFN, *DFD, the number of degrees of

5561

// freedom for the numerator and denominator.

5562

5563

// Output, double *CUM, *CCUM, the value of the F CDF and

5564

// the complementary F CDF.

5565

5566

{

5567

# define half 0.5e0

5568

# define done 1.0e0

5569

5570

static double dsum,prod,xx,yy;

5571

static int ierr;

5572

static double T1,T2;

5573

5574

if(!(*f <= 0.0e0)) goto S10;

5575

*cum = 0.0e0;

5576

*ccum = 1.0e0;

5577

return;

5578

S10:

5579

prod = *dfn**f;

5580

5581

// XX is such that the incomplete beta with parameters

5582

// DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM

5583

// YY is 1 - XX

5584

// Calculate the smaller of XX and YY accurately

5585

5586

dsum = *dfd+prod;

5587

xx = *dfd/dsum;

5588

5589

if ( xx > half )

5590

{

5591

yy = prod/dsum;

5592

xx = done-yy;

5593

}

5594

else

5595

{

5596

yy = done-xx;

5597

}

5598

5599

T1 = *dfd*half;

5600

T2 = *dfn*half;

5601

beta_inc ( &T1, &T2, &xx, &yy, ccum, cum, &ierr );

5602

return;

5603

# undef half

5604

# undef done

5605

}

5606

//****************************************************************************80

5607

5608

void cumfnc ( double *f, double *dfn, double *dfd, double *pnonc,

5609

double *cum, double *ccum )

5610

5611

//****************************************************************************80

5612

5613

// Purpose:

5614

5615

// CUMFNC evaluates the cumulative noncentral F distribution.

5616

5617

// Discussion:

5618

5619

// This routine computes the noncentral F distribution with DFN and DFD

5620

// degrees of freedom and noncentrality parameter PNONC.

5621

5622

// The series is calculated backward and forward from J = LAMBDA/2

5623

// (this is the term with the largest Poisson weight) until

5624

// the convergence criterion is met.

5625

5626

// The sum continues until a succeeding term is less than EPS

5627

// times the sum (or the sum is less than 1.0e-20). EPS is

5628

// set to 1.0e-4 in a data statement which can be changed.

5629

5630

5631

// The original version of this routine allowed the input values

5632

// of DFN and DFD to be negative (nonsensical) or zero (which

5633

// caused numerical overflow.) I have forced both these values

5634

// to be at least 1.

5635

5636

// Modified:

5637

5638

// 15 June 2004

5639

5640

// Reference:

5641

5642

// Milton Abramowitz and Irene Stegun,

5643

// Handbook of Mathematical Functions

5644

// 1966, Formula 26.5.16, 26.6.17, 26.6.18, 26.6.20.

5645

5646

// Parameters:

5647

5648

// Input, double *F, the upper limit of integration.

5649

5650

// Input, double *DFN, *DFD, the number of degrees of freedom

5651

// in the numerator and denominator. Both DFN and DFD must be positive,

5652

// and normally would be integers. This routine requires that they

5653

// be no less than 1.

5654

5655

// Input, double *PNONC, the noncentrality parameter.

5656

5657

// Output, double *CUM, *CCUM, the noncentral F CDF and

5658

// complementary CDF.

5659

5660

{

5661

# define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum)

5662

# define half 0.5e0

5663

# define done 1.0e0

5664

5665

static double eps = 1.0e-4;

5666

static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum,

5667

upterm,xmult,xnonc;

5668

static int i,icent,ierr;

5669

static double T1,T2,T3,T4,T5,T6;

5670

5671

if(!(*f <= 0.0e0)) goto S10;

5672

*cum = 0.0e0;

5673

*ccum = 1.0e0;

5674

return;

5675

S10:

5676

if(!(*pnonc < 1.0e-10)) goto S20;

5677

5678

// Handle case in which the non-centrality parameter is

5679

// (essentially) zero.

5680

5681

cumf(f,dfn,dfd,cum,ccum);

5682

return;

5683

S20:

5684

xnonc = *pnonc/2.0e0;

5685

5686

// Calculate the central term of the poisson weighting factor.

5687

5688

icent = ( int ) xnonc;

5689

if(icent == 0) icent = 1;

5690

5691

// Compute central weight term

5692

5693

T1 = (double)(icent+1);

5694

centwt = exp(-xnonc+(double)icent*log(xnonc)- gamma_log ( &T1 ) );

5695

5696

// Compute central incomplete beta term

5697

// Assure that minimum of arg to beta and 1 - arg is computed

5698

// accurately.

5699

5700

prod = *dfn**f;

5701

dsum = *dfd+prod;

5702

yy = *dfd/dsum;

5703

if(yy > half) {

5704

xx = prod/dsum;

5705

yy = done-xx;

5706

}

5707

else xx = done-yy;

5708

T2 = *dfn*half+(double)icent;

5709

T3 = *dfd*half;

5710

beta_inc ( &T2, &T3, &xx, &yy, &betdn, &dummy, &ierr );

5711

adn = *dfn/2.0e0+(double)icent;

5712

aup = adn;

5713

b = *dfd/2.0e0;

5714

betup = betdn;

5715

sum = centwt*betdn;

5716

5717

// Now sum terms backward from icent until convergence or all done

5718

5719

xmult = centwt;

5720

i = icent;

5721

T4 = adn+b;

5722

T5 = adn+1.0e0;

5723

dnterm = exp( gamma_log ( &T4 ) - gamma_log ( &T5 )

5724

- gamma_log ( &b ) + adn * log ( xx ) + b * log(yy));

5725

S30:

5726

if(qsmall(xmult*betdn) || i <= 0) goto S40;

5727

xmult *= ((double)i/xnonc);

5728

i -= 1;

5729

adn -= 1.0;

5730

dnterm = (adn+1.0)/((adn+b)*xx)*dnterm;

5731

betdn += dnterm;

5732

sum += (xmult*betdn);

5733

goto S30;

5734

S40:

5735

i = icent+1;

5736

5737

// Now sum forwards until convergence

5738

5739

xmult = centwt;

5740

if(aup-1.0+b == 0) upterm = exp(-gamma_log ( &aup )

5741

- gamma_log ( &b ) + (aup-1.0)*log(xx)+

5742

b*log(yy));

5743

else {

5744

T6 = aup-1.0+b;

5745

upterm = exp( gamma_log ( &T6 ) - gamma_log ( &aup )

5746

- gamma_log ( &b ) + (aup-1.0)*log(xx)+b*

5747

log(yy));

5748

}

5749

goto S60;

5750

S50:

5751

if(qsmall(xmult*betup)) goto S70;

5752

S60:

5753

xmult *= (xnonc/(double)i);

5754

i += 1;

5755

aup += 1.0;

5756

upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm;

5757

betup -= upterm;

5758

sum += (xmult*betup);

5759

goto S50;

5760

S70:

5761

*cum = sum;

5762

*ccum = 0.5e0+(0.5e0-*cum);

5763

return;

5764

# undef qsmall

5765

# undef half

5766

# undef done

5767

}

5768

//****************************************************************************80

5769

5770

void cumgam ( double *x, double *a, double *cum, double *ccum )

5771

5772

//****************************************************************************80

5773

5774

// Purpose:

5775

5776

// CUMGAM evaluates the cumulative incomplete gamma distribution.

5777

5778

// Discussion:

5779

5780

// This routine computes the cumulative distribution function of the

5781

// incomplete gamma distribution, i.e., the integral from 0 to X of

5782

5783

// (1/GAM(A))*EXP(-T)*T**(A-1) DT

5784

5785

// where GAM(A) is the complete gamma function of A, i.e.,

5786

5787

// GAM(A) = integral from 0 to infinity of EXP(-T)*T**(A-1) DT

5788

5789

// Parameters:

5790

5791

// Input, double *X, the upper limit of integration.

5792

5793

// Input, double *A, the shape parameter of the incomplete

5794

// Gamma distribution.

5795

5796

// Output, double *CUM, *CCUM, the incomplete Gamma CDF and

5797

// complementary CDF.

5798

5799

{

5800

static int K1 = 0;

5801

5802

if(!(*x <= 0.0e0)) goto S10;

5803

*cum = 0.0e0;

5804

*ccum = 1.0e0;

5805

return;

5806

S10:

5807

gamma_inc ( a, x, cum, ccum, &K1 );

5808

5809

// Call gratio routine

5810

5811

return;

5812

}

5813

//****************************************************************************80

5814

5815

void cumnbn ( double *s, double *xn, double *pr, double *ompr,

5816

double *cum, double *ccum )

5817

5818

//****************************************************************************80

5819

5820

// Purpose:

5821

5822

// CUMNBN evaluates the cumulative negative binomial distribution.

5823

5824

// Discussion:

5825

5826

// This routine returns the probability that there will be F or

5827

// fewer failures before there are S successes, with each binomial

5828

// trial having a probability of success PR.

5829

5830

// Prob(# failures = F | S successes, PR) =

5831

// ( S + F - 1 )

5832

// ( ) * PR^S * (1-PR)^F

5833

// ( F )

5834

5835

// Reference:

5836

5837

// Milton Abramowitz and Irene Stegun,

5838

// Handbook of Mathematical Functions

5839

// 1966, Formula 26.5.26.

5840

5841

// Parameters:

5842

5843

// Input, double *F, the number of failures.

5844

5845

// Input, double *S, the number of successes.

5846

5847

// Input, double *PR, *OMPR, the probability of success on

5848

// each binomial trial, and the value of (1-PR).

5849

5850

// Output, double *CUM, *CCUM, the negative binomial CDF,

5851

// and the complementary CDF.

5852

5853

{

5854

static double T1;

5855

5856

T1 = *s+1.e0;

5857

cumbet(pr,ompr,xn,&T1,cum,ccum);

5858

return;

5859

}

5860

//****************************************************************************80

5861

5862

void cumnor ( double *arg, double *result, double *ccum )

5863

5864

//****************************************************************************80

5865

5866

// Purpose:

5867

5868

// CUMNOR computes the cumulative normal distribution.

5869

5870

// Discussion:

5871

5872

// This function evaluates the normal distribution function:

5873

5874

// / x

5875

// 1 | -t*t/2

5876

// P(x) = ----------- | e dt

5877

// sqrt(2 pi) |

5878

// /-oo

5879

5880

// This transportable program uses rational functions that

5881

// theoretically approximate the normal distribution function to

5882

// at least 18 significant decimal digits. The accuracy achieved

5883

// depends on the arithmetic system, the compiler, the intrinsic

5884

// functions, and proper selection of the machine-dependent

5885

// constants.

5886

5887

// Author:

5888

5889

// William Cody

5890

// Mathematics and Computer Science Division

5891

// Argonne National Laboratory

5892

// Argonne, IL 60439

5893

5894

// Reference:

5895

5896

// William Cody,

5897

// Rational Chebyshev approximations for the error function,

5898

// Mathematics of Computation,

5899

// 1969, pages 631-637.

5900

5901

// William Cody,

5902

// Algorithm 715:

5903

// SPECFUN - A Portable FORTRAN Package of Special Function Routines

5904

// and Test Drivers,

5905

// ACM Transactions on Mathematical Software,

5906

// Volume 19, 1993, pages 22-32.

5907

5908

// Parameters:

5909

5910

// Input, double *ARG, the upper limit of integration.

5911

5912

// Output, double *CUM, *CCUM, the Normal density CDF and

5913

// complementary CDF.

5914

5915

// Local Parameters:

5916

5917

// Local, double EPS, the argument below which anorm(x)

5918

// may be represented by 0.5D+00 and above which x*x will not underflow.

5919

// A conservative value is the largest machine number X

5920

// such that 1.0D+00 + X = 1.0D+00 to machine precision.

5921

5922

{

5923

static double a[5] = {

5924

2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03,

5925

1.8154981253343561249e04,6.5682337918207449113e-2

5926

};

5927

static double b[4] = {

5928

4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04,

5929

4.5507789335026729956e04

5930

};

5931

static double c[9] = {

5932

3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01,

5933

5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03,

5934

1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8

5935

};

5936

static double d[8] = {

5937

2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03,

5938

6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04,

5939

3.8912003286093271411e04,1.9685429676859990727e04

5940

};

5941

static double half = 0.5e0;

5942

static double p[6] = {

5943

2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2,

5944

1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2

5945

};

5946

static double one = 1.0e0;

5947

static double q[5] = {

5948

1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2,

5949

3.78239633202758244e-3,7.29751555083966205e-5

5950

};

5951

static double sixten = 1.60e0;

5952

static double sqrpi = 3.9894228040143267794e-1;

5953

static double thrsh = 0.66291e0;

5954

static double root32 = 5.656854248e0;

5955

static double zero = 0.0e0;

5956

static int K1 = 1;

5957

static int K2 = 2;

5958

static int i;

5959

static double del,eps,temp,x,xden,xnum,y,xsq,min;

5960

5961

// Machine dependent constants

5962

5963

eps = dpmpar(&K1)*0.5e0;

5964

min = dpmpar(&K2);

5965

x = *arg;

5966

y = fabs(x);

5967

if(y <= thrsh) {

5968

5969

// Evaluate anorm for |X| <= 0.66291

5970

5971

xsq = zero;

5972

if(y > eps) xsq = x*x;

5973

xnum = a[4]*xsq;

5974

xden = xsq;

5975

for ( i = 0; i < 3; i++ )

5976

{

5977

xnum = (xnum+a[i])*xsq;

5978

xden = (xden+b[i])*xsq;

5979

}

5980

*result = x*(xnum+a[3])/(xden+b[3]);

5981

temp = *result;

5982

*result = half+temp;

5983

*ccum = half-temp;

5984

}

5985

5986

// Evaluate anorm for 0.66291 <= |X| <= sqrt(32)

5987

5988

else if(y <= root32) {

5989

xnum = c[8]*y;

5990

xden = y;

5991

for ( i = 0; i < 7; i++ )

5992

{

5993

xnum = (xnum+c[i])*y;

5994

xden = (xden+d[i])*y;

5995

}

5996

*result = (xnum+c[7])/(xden+d[7]);

5997

xsq = fifdint(y*sixten)/sixten;

5998

del = (y-xsq)*(y+xsq);

5999

*result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;

6000

*ccum = one-*result;

6001

if(x > zero) {

6002

temp = *result;

6003

*result = *ccum;

6004

*ccum = temp;

6005

}

6006

}

6007

6008

// Evaluate anorm for |X| > sqrt(32)

6009

6010

else {

6011

*result = zero;

6012

xsq = one/(x*x);

6013

xnum = p[5]*xsq;

6014

xden = xsq;

6015

for ( i = 0; i < 4; i++ )

6016

{

6017

xnum = (xnum+p[i])*xsq;

6018

xden = (xden+q[i])*xsq;

6019

}

6020

*result = xsq*(xnum+p[4])/(xden+q[4]);

6021

*result = (sqrpi-*result)/y;

6022

xsq = fifdint(x*sixten)/sixten;

6023

del = (x-xsq)*(x+xsq);

6024

*result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;

6025

*ccum = one-*result;

6026

if(x > zero) {

6027

temp = *result;

6028

*result = *ccum;

6029

*ccum = temp;

6030

}

6031

}

6032

if(*result < min) *result = 0.0e0;

6033

6034

// Fix up for negative argument, erf, etc.

6035

6036

if(*ccum < min) *ccum = 0.0e0;

6037

}

6038

//****************************************************************************80

6039

6040

void cumpoi ( double *s, double *xlam, double *cum, double *ccum )

6041

6042

//****************************************************************************80

6043

6044

// Purpose:

6045

6046

// CUMPOI evaluates the cumulative Poisson distribution.

6047

6048

// Discussion:

6049

6050

// CUMPOI returns the probability of S or fewer events in a Poisson

6051

// distribution with mean XLAM.

6052

6053

// Reference:

6054

6055

// Milton Abramowitz and Irene Stegun,

6056

// Handbook of Mathematical Functions,

6057

// Formula 26.4.21.

6058

6059

// Parameters:

6060

6061

// Input, double *S, the upper limit of cumulation of the

6062

// Poisson density function.

6063

6064

// Input, double *XLAM, the mean of the Poisson distribution.

6065

6066

// Output, double *CUM, *CCUM, the Poisson density CDF and

6067

// complementary CDF.

6068

6069

{

6070

static double chi,df;

6071

6072

df = 2.0e0*(*s+1.0e0);

6073

chi = 2.0e0**xlam;

6074

cumchi(&chi,&df,ccum,cum);

6075

return;

6076

}

6077

//****************************************************************************80

6078

6079

void cumt ( double *t, double *df, double *cum, double *ccum )

6080

6081

//****************************************************************************80

6082

6083

// Purpose:

6084

6085

// CUMT evaluates the cumulative T distribution.

6086

6087

// Reference:

6088

6089

// Milton Abramowitz and Irene Stegun,

6090

// Handbook of Mathematical Functions,

6091

// Formula 26.5.27.

6092

6093

// Parameters:

6094

6095

// Input, double *T, the upper limit of integration.

6096

6097

// Input, double *DF, the number of degrees of freedom of

6098

// the T distribution.

6099

6100

// Output, double *CUM, *CCUM, the T distribution CDF and

6101

// complementary CDF.

6102

6103

{

6104

static double a;

6105

static double dfptt;

6106

static double K2 = 0.5e0;

6107

static double oma;

6108

static double T1;

6109

static double tt;

6110

static double xx;

6111

static double yy;

6112

6113

tt = (*t) * (*t);

6114

dfptt = ( *df ) + tt;

6115

xx = *df / dfptt;

6116

yy = tt / dfptt;

6117

T1 = 0.5e0 * ( *df );

6118

cumbet ( &xx, &yy, &T1, &K2, &a, &oma );

6119

6120

if ( *t <= 0.0e0 )

6121

{

6122

*cum = 0.5e0 * a;

6123

*ccum = oma + ( *cum );

6124

}

6125

else

6126

{

6127

*ccum = 0.5e0 * a;

6128

*cum = oma + ( *ccum );

6129

}

6130

return;

6131

}

6132

//****************************************************************************80

6133

6134

double dbetrm ( double *a, double *b )

6135

6136

//****************************************************************************80

6137

6138

// Purpose:

6139

6140

// DBETRM computes the Sterling remainder for the complete beta function.

6141

6142

// Discussion:

6143

6144

// Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)

6145

// where Lgamma is the log of the (complete) gamma function

6146

6147

// Let ZZ be approximation obtained if each log gamma is approximated

6148

// by Sterling's formula, i.e.,

6149

// Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5D+00 ) * LOG( Z ) - Z

6150

6151

// The Sterling remainder is Log(Beta(A,B)) - ZZ.

6152

6153

// Parameters:

6154

6155

// Input, double *A, *B, the parameters of the Beta function.

6156

6157

// Output, double DBETRM, the Sterling remainder.

6158

6159

{

6160

static double dbetrm,T1,T2,T3;

6161

6162

// Try to sum from smallest to largest

6163

6164

T1 = *a+*b;

6165

dbetrm = -dstrem(&T1);

6166

T2 = fifdmax1(*a,*b);

6167

dbetrm += dstrem(&T2);

6168

T3 = fifdmin1(*a,*b);

6169

dbetrm += dstrem(&T3);

6170

return dbetrm;

6171

}

6172

//****************************************************************************80

6173

6174

double dexpm1 ( double *x )

6175

6176

//****************************************************************************80

6177

6178

// Purpose:

6179

6180

// DEXPM1 evaluates the function EXP(X) - 1.

6181

6182

// Reference:

6183

6184

// Armido DiDinato and Alfred Morris,

6185

// Algorithm 708:

6186

// Significant Digit Computation of the Incomplete Beta Function Ratios,

6187

// ACM Transactions on Mathematical Software,

6188

// Volume 18, 1993, pages 360-373.

6189

6190

// Parameters:

6191

6192

// Input, double *X, the value at which exp(X)-1 is desired.

6193

6194

// Output, double DEXPM1, the value of exp(X)-1.

6195

6196

{

6197

static double p1 = .914041914819518e-09;

6198

static double p2 = .238082361044469e-01;

6199

static double q1 = -.499999999085958e+00;

6200

static double q2 = .107141568980644e+00;

6201

static double q3 = -.119041179760821e-01;

6202

static double q4 = .595130811860248e-03;

6203

static double dexpm1;

6204

double w;

6205

6206

if ( fabs(*x) <= 0.15e0 )

6207

{

6208

dexpm1 = *x * ( ( (

6209

p2 * *x

6210

+ p1 ) * *x

6211

+ 1.0e0 )

6212

/((((

6213

q4 * *x

6214

+ q3 ) * *x

6215

+ q2 ) * *x

6216

+ q1 ) * *x

6217

+ 1.0e0 ) );

6218

}

6219

else if ( *x <= 0.0e0 )

6220

{

6221

w = exp(*x);

6222

dexpm1 = w-0.5e0-0.5e0;

6223

}

6224

else

6225

{

6226

w = exp(*x);

6227

dexpm1 = w*(0.5e0+(0.5e0-1.0e0/w));

6228

}

6229

6230

return dexpm1;

6231

}

6232

//****************************************************************************80

6233

6234

double dinvnr ( double *p, double *q )

6235

6236

//****************************************************************************80

6237

6238

// Purpose:

6239

6240

// DINVNR computes the inverse of the normal distribution.

6241

6242

// Discussion:

6243

6244

// Returns X such that CUMNOR(X) = P, i.e., the integral from -

6245

// infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P

6246

6247

// The rational function on page 95 of Kennedy and Gentle is used as a start

6248

// value for the Newton method of finding roots.

6249

6250

// Reference:

6251

6252

// Kennedy and Gentle,

6253

// Statistical Computing,

6254

// Marcel Dekker, NY, 1980,

6255

// QA276.4 K46

6256

6257

// Parameters:

6258

6259

// Input, double *P, *Q, the probability, and the complementary

6260

// probability.

6261

6262

// Output, double DINVNR, the argument X for which the

6263

// Normal CDF has the value P.

6264

6265

{

6266

# define maxit 100

6267

# define eps (1.0e-13)

6268

# define r2pi 0.3989422804014326e0

6269

# define nhalf (-0.5e0)

6270

# define dennor(x) (r2pi*exp(nhalf*(x)*(x)))

6271

6272

static double dinvnr,strtx,xcur,cum,ccum,pp,dx;

6273

static int i;

6274

static unsigned long qporq;

6275

6276

6277

// FIND MINIMUM OF P AND Q

6278

6279

qporq = *p <= *q;

6280

if(!qporq) goto S10;

6281

pp = *p;

6282

goto S20;

6283

S10:

6284

pp = *q;

6285

S20:

6286

6287

// INITIALIZATION STEP

6288

6289

strtx = stvaln(&pp);

6290

xcur = strtx;

6291

6292

// NEWTON INTERATIONS

6293

6294

for ( i = 1; i <= maxit; i++ )

6295

{

6296

cumnor(&xcur,&cum,&ccum);

6297

dx = (cum-pp)/dennor(xcur);

6298

xcur -= dx;

6299

if(fabs(dx/xcur) < eps) goto S40;

6300

}

6301

dinvnr = strtx;

6302

6303

// IF WE GET HERE, NEWTON HAS FAILED

6304

6305

if(!qporq) dinvnr = -dinvnr;

6306

return dinvnr;

6307

S40:

6308

6309

// IF WE GET HERE, NEWTON HAS SUCCEDED

6310

6311

dinvnr = xcur;

6312

if(!qporq) dinvnr = -dinvnr;

6313

return dinvnr;

6314

# undef maxit

6315

# undef eps

6316

# undef r2pi

6317

# undef nhalf

6318

# undef dennor

6319

}

6320

//****************************************************************************80

6321

6322

void dinvr ( int *status, double *x, double *fx,

6323

unsigned long *qleft, unsigned long *qhi )

6324

6325

//****************************************************************************80

6326

6327

// Purpose:

6328

6329

// DINVR bounds the zero of the function and invokes DZROR.

6330

6331

// Discussion:

6332

6333

// This routine seeks to find bounds on a root of the function and

6334

// invokes ZROR to perform the zero finding. STINVR must have been

6335

// called before this routine in order to set its parameters.

6336

6337

// Reference:

6338

6339

// J C P Bus and T J Dekker,

6340

// Two Efficient Algorithms with Guaranteed Convergence for

6341

// Finding a Zero of a Function,

6342

// ACM Transactions on Mathematical Software,

6343

// Volume 1, Number 4, pages 330-345, 1975.

6344

6345

// Parameters:

6346

6347

// Input/output, integer STATUS. At the beginning of a zero finding

6348

// problem, STATUS should be set to 0 and INVR invoked. The value

6349

// of parameters other than X will be ignored on this call.

6350

// If INVR needs the function to be evaluated, it will set STATUS to 1

6351

// and return. The value of the function should be set in FX and INVR

6352

// again called without changing any of its other parameters.

6353

// If INVR finishes without error, it returns with STATUS 0, and X an

6354

// approximate root of F(X).

6355

// If INVR cannot bound the function, it returns a negative STATUS and

6356

// sets QLEFT and QHI.

6357

6358

// Output, double precision X, the value at which F(X) is to be evaluated.

6359

6360

// Input, double precision FX, the value of F(X) calculated by the user

6361

// on the previous call, when INVR returned with STATUS = 1.

6362

6363

// Output, logical QLEFT, is defined only if QMFINV returns FALSE. In that

6364

// case, QLEFT is TRUE if the stepping search terminated unsucessfully

6365

// at SMALL, and FALSE if the search terminated unsucessfully at BIG.

6366

6367

// Output, logical QHI, is defined only if QMFINV returns FALSE. In that

6368

// case, it is TRUE if Y < F(X) at the termination of the search and FALSE

6369

// if F(X) < Y.

6370

6371

{

6372

E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL);

6373

}

6374

//****************************************************************************80

6375

6376

double dlanor ( double *x )

6377

6378

//****************************************************************************80

6379

6380

// Purpose:

6381

6382

// DLANOR evaluates the logarithm of the asymptotic Normal CDF.

6383

6384

// Discussion:

6385

6386

// This routine computes the logarithm of the cumulative normal distribution

6387

// from abs ( x ) to infinity for 5 <= abs ( X ).

6388

6389

// The relative error at X = 5 is about 0.5D-5.

6390

6391

// Reference:

6392

6393

// Milton Abramowitz and Irene Stegun,

6394

// Handbook of Mathematical Functions

6395

// 1966, Formula 26.2.12.

6396

6397

// Parameters:

6398

6399

// Input, double *X, the value at which the Normal CDF is to be

6400

// evaluated. It is assumed that 5 <= abs ( X ).

6401

6402

// Output, double DLANOR, the logarithm of the asymptotic

6403

// Normal CDF.

6404

6405

{

6406

# define dlsqpi 0.91893853320467274177e0

6407

6408

static double coef[12] = {

6409

-1.0e0,3.0e0,-15.0e0,105.0e0,-945.0e0,10395.0e0,-135135.0e0,2027025.0e0,

6410

-34459425.0e0,654729075.0e0,-13749310575.e0,316234143225.0e0

6411

};

6412

static int K1 = 12;

6413

static double dlanor,approx,correc,xx,xx2,T2;

6414

6415

xx = fabs(*x);

6416

if ( xx < 5.0e0 )

6417

{

6418

ftnstop(" Argument too small in DLANOR");

6419

}

6420

approx = -dlsqpi-0.5e0*xx*xx-log(xx);

6421

xx2 = xx*xx;

6422

T2 = 1.0e0/xx2;

6423

correc = eval_pol ( coef, &K1, &T2 ) / xx2;

6424

correc = alnrel ( &correc );

6425

dlanor = approx+correc;

6426

return dlanor;

6427

# undef dlsqpi

6428

}

6429

//****************************************************************************80

6430

6431

double dpmpar ( int *i )

6432

6433

//****************************************************************************80

6434

6435

// Purpose:

6436

6437

// DPMPAR provides machine constants for double precision arithmetic.

6438

6439

// Discussion:

6440

6441

// DPMPAR PROVIDES THE double PRECISION MACHINE CONSTANTS FOR

6442

// THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT

6443

// I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE

6444

// double PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND

6445

// ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN

6446

6447

// DPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,

6448

6449

// DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,

6450

6451

// DPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.

6452

6453

// WRITTEN BY

6454

// ALFRED H. MORRIS, JR.

6455

// NAVAL SURFACE WARFARE CENTER

6456

// DAHLGREN VIRGINIA

6457

6458

// MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE

6459

// CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS

6460

// MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION

6461

6462

{

6463

static int K1 = 4;

6464

static int K2 = 8;

6465

static int K3 = 9;

6466

static int K4 = 10;

6467

static double value,b,binv,bm1,one,w,z;

6468

static int emax,emin,ibeta,m;

6469

6470

if(*i > 1) goto S10;

6471

b = ipmpar(&K1);

6472

m = ipmpar(&K2);

6473

value = pow(b,(double)(1-m));

6474

return value;

6475

S10:

6476

if(*i > 2) goto S20;

6477

b = ipmpar(&K1);

6478

emin = ipmpar(&K3);

6479

one = 1.0;

6480

binv = one/b;

6481

w = pow(b,(double)(emin+2));

6482

value = w*binv*binv*binv;

6483

return value;

6484

S20:

6485

ibeta = ipmpar(&K1);

6486

m = ipmpar(&K2);

6487

emax = ipmpar(&K4);

6488

b = ibeta;

6489

bm1 = ibeta-1;

6490

one = 1.0;

6491

z = pow(b,(double)(m-1));

6492

w = ((z-one)*b+bm1)/(b*z);

6493

z = pow(b,(double)(emax-2));

6494

value = w*z*b*b;

6495

return value;

6496

}

6497

//****************************************************************************80

6498

6499

void dstinv ( double *zsmall, double *zbig, double *zabsst,

6500

double *zrelst, double *zstpmu, double *zabsto, double *zrelto )

6501

6502

//****************************************************************************80

6503

6504

// Purpose:

6505

6506

// DSTINV seeks a value X such that F(X) = Y.

6507

6508

// Discussion:

6509

6510

// Double Precision - SeT INverse finder - Reverse Communication

6511

// Function

6512

// Concise Description - Given a monotone function F finds X

6513

// such that F(X) = Y. Uses Reverse communication -- see invr.

6514

// This routine sets quantities needed by INVR.

6515

// More Precise Description of INVR -

6516

// F must be a monotone function, the results of QMFINV are

6517

// otherwise undefined. QINCR must be .TRUE. if F is non-

6518

// decreasing and .FALSE. if F is non-increasing.

6519

// QMFINV will return .TRUE. if and only if F(SMALL) and

6520

// F(BIG) bracket Y, i. e.,

6521

// QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or

6522

// QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL)

6523

// if QMFINV returns .TRUE., then the X returned satisfies

6524

// the following condition. let

6525

// TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))

6526

// then if QINCR is .TRUE.,

6527

// F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X))

6528

// and if QINCR is .FALSE.

6529

// F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X))

6530

// Arguments

6531

// SMALL --> The left endpoint of the interval to be

6532

// searched for a solution.

6533

// SMALL is DOUBLE PRECISION

6534

// BIG --> The right endpoint of the interval to be

6535

// searched for a solution.

6536

// BIG is DOUBLE PRECISION

6537

// ABSSTP, RELSTP --> The initial step size in the search

6538

// is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm.

6539

// ABSSTP is DOUBLE PRECISION

6540

// RELSTP is DOUBLE PRECISION

6541

// STPMUL --> When a step doesn't bound the zero, the step

6542

// size is multiplied by STPMUL and another step

6543

// taken. A popular value is 2.0

6544

// DOUBLE PRECISION STPMUL

6545

// ABSTOL, RELTOL --> Two numbers that determine the accuracy

6546

// of the solution. See function for a precise definition.

6547

// ABSTOL is DOUBLE PRECISION

6548

// RELTOL is DOUBLE PRECISION

6549

// Method

6550

// Compares F(X) with Y for the input value of X then uses QINCR

6551

// to determine whether to step left or right to bound the

6552

// desired x. the initial step size is

6553

// MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X.

6554

// Iteratively steps right or left until it bounds X.

6555

// At each step which doesn't bound X, the step size is doubled.

6556

// The routine is careful never to step beyond SMALL or BIG. If

6557

// it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE.

6558

// after setting QLEFT and QHI.

6559

// If X is successfully bounded then Algorithm R of the paper

6560

// 'Two Efficient Algorithms with Guaranteed Convergence for

6561

// Finding a Zero of a Function' by J. C. P. Bus and

6562

// T. J. Dekker in ACM Transactions on Mathematical

6563

// Software, Volume 1, No. 4 page 330 (DEC. '75) is employed

6564

// to find the zero of the function F(X)-Y. This is routine

6565

// QRZERO.

6566

6567

{

6568

E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall,

6569

zstpmu);

6570

}

6571

//****************************************************************************80

6572

6573

double dstrem ( double *z )

6574

6575

//****************************************************************************80

6576

6577

// Purpose:

6578

6579

// DSTREM computes the Sterling remainder ln ( Gamma ( Z ) ) - Sterling ( Z ).

6580

6581

// Discussion:

6582

6583

// This routine returns

6584

6585

// ln ( Gamma ( Z ) ) - Sterling ( Z )

6586

6587

// where Sterling(Z) is Sterling's approximation to ln ( Gamma ( Z ) ).

6588

6589

// Sterling(Z) = ln ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * ln ( Z ) - Z

6590

6591

// If 6 <= Z, the routine uses 9 terms of a series in Bernoulli numbers,

6592

// with values calculated using Maple.

6593

6594

// Otherwise, the difference is computed explicitly.

6595

6596

// Modified:

6597

6598

// 14 June 2004

6599

6600

// Parameters:

6601

6602

// Input, double *Z, the value at which the Sterling

6603

// remainder is to be calculated. Z must be positive.

6604

6605

// Output, double DSTREM, the Sterling remainder.

6606

6607

{

6608

# define hln2pi 0.91893853320467274178e0

6609

# define ncoef 10

6610

6611

static double coef[ncoef] = {

6612

0.0e0,0.0833333333333333333333333333333e0,

6613

-0.00277777777777777777777777777778e0,0.000793650793650793650793650793651e0,

6614

-0.000595238095238095238095238095238e0,

6615

0.000841750841750841750841750841751e0,-0.00191752691752691752691752691753e0,

6616

0.00641025641025641025641025641026e0,-0.0295506535947712418300653594771e0,

6617

0.179644372368830573164938490016e0

6618

};

6619

static int K1 = 10;

6620

static double dstrem,sterl,T2;

6621

6622

// For information, here are the next 11 coefficients of the

6623

// remainder term in Sterling's formula

6624

// -1.39243221690590111642743221691

6625

// 13.4028640441683919944789510007

6626

// -156.848284626002017306365132452

6627

// 2193.10333333333333333333333333

6628

// -36108.7712537249893571732652192

6629

// 691472.268851313067108395250776

6630

// -0.152382215394074161922833649589D8

6631

// 0.382900751391414141414141414141D9

6632

// -0.108822660357843910890151491655D11

6633

// 0.347320283765002252252252252252D12

6634

// -0.123696021422692744542517103493D14

6635

6636

if(*z <= 0.0e0)

6637

{

6638

ftnstop ( "Zero or negative argument in DSTREM" );

6639

}

6640

if(!(*z > 6.0e0)) goto S10;

6641

T2 = 1.0e0/pow(*z,2.0);

6642

dstrem = eval_pol ( coef, &K1, &T2 )**z;

6643

goto S20;

6644

S10:

6645

sterl = hln2pi+(*z-0.5e0)*log(*z)-*z;

6646

dstrem = gamma_log ( z ) - sterl;

6647

S20:

6648

return dstrem;

6649

# undef hln2pi

6650

# undef ncoef

6651

}

6652

//****************************************************************************80

6653

6654

void dstzr ( double *zxlo, double *zxhi, double *zabstl, double *zreltl )

6655

6656

//****************************************************************************80

6657

6658

// Purpose:

6659

6660

// DSTXR sets quantities needed by the zero finder.

6661

6662

// Discussion:

6663

6664

// Double precision SeT ZeRo finder - Reverse communication version

6665

// Function

6666

// Sets quantities needed by ZROR. The function of ZROR

6667

// and the quantities set is given here.

6668

// Concise Description - Given a function F

6669

// find XLO such that F(XLO) = 0.

6670

// More Precise Description -

6671

// Input condition. F is a double function of a single

6672

// double argument and XLO and XHI are such that

6673

// F(XLO)*F(XHI) .LE. 0.0

6674

// If the input condition is met, QRZERO returns .TRUE.

6675

// and output values of XLO and XHI satisfy the following

6676

// F(XLO)*F(XHI) .LE. 0.

6677

// ABS(F(XLO) .LE. ABS(F(XHI)

6678

// ABS(XLO-XHI) .LE. TOL(X)

6679

// where

6680

// TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))

6681

// If this algorithm does not find XLO and XHI satisfying

6682

// these conditions then QRZERO returns .FALSE. This

6683

// implies that the input condition was not met.

6684

// Arguments

6685

// XLO --> The left endpoint of the interval to be

6686

// searched for a solution.

6687

// XLO is DOUBLE PRECISION

6688

// XHI --> The right endpoint of the interval to be

6689

// for a solution.

6690

// XHI is DOUBLE PRECISION

6691

// ABSTOL, RELTOL --> Two numbers that determine the accuracy

6692

// of the solution. See function for a

6693

// precise definition.

6694

// ABSTOL is DOUBLE PRECISION

6695

// RELTOL is DOUBLE PRECISION

6696

// Method

6697

// Algorithm R of the paper 'Two Efficient Algorithms with

6698

// Guaranteed Convergence for Finding a Zero of a Function'

6699

// by J. C. P. Bus and T. J. Dekker in ACM Transactions on

6700

// Mathematical Software, Volume 1, no. 4 page 330

6701

// (Dec. '75) is employed to find the zero of F(X)-Y.

6702

6703

{

6704

E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo);

6705

}

6706

//****************************************************************************80

6707

6708

double dt1 ( double *p, double *q, double *df )

6709

6710

//****************************************************************************80

6711

6712

// Purpose:

6713

6714

// DT1 computes an approximate inverse of the cumulative T distribution.

6715

6716

// Discussion:

6717

6718

// Returns the inverse of the T distribution function, i.e.,

6719

// the integral from 0 to INVT of the T density is P. This is an

6720

// initial approximation.

6721

6722

// Parameters:

6723

6724

// Input, double *P, *Q, the value whose inverse from the

6725

// T distribution CDF is desired, and the value (1-P).

6726

6727

// Input, double *DF, the number of degrees of freedom of the

6728

// T distribution.

6729

6730

// Output, double DT1, the approximate value of X for which

6731

// the T density CDF with DF degrees of freedom has value P.

6732

6733

{

6734

static double coef[4][5] = {

6735

1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,3.0e0,16.0e0,5.0e0,0.0e0,0.0e0,-15.0e0,17.0e0,

6736

19.0e0,3.0e0,0.0e0,-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0

6737

};

6738

static double denom[4] = {

6739

4.0e0,96.0e0,384.0e0,92160.0e0

6740

};

6741

static int ideg[4] = {

6742

2,3,4,5

6743

};

6744

static double dt1,denpow,sum,term,x,xp,xx;

6745

static int i;

6746

6747

x = fabs(dinvnr(p,q));

6748

xx = x*x;

6749

sum = x;

6750

denpow = 1.0e0;

6751

for ( i = 0; i < 4; i++ )

6752

{

6753

term = eval_pol ( &coef[i][0], &ideg[i], &xx ) * x;

6754

denpow *= *df;

6755

sum += (term/(denpow*denom[i]));

6756

}

6757

if(!(*p >= 0.5e0)) goto S20;

6758

xp = sum;

6759

goto S30;

6760

S20:

6761

xp = -sum;

6762

S30:

6763

dt1 = xp;

6764

return dt1;

6765

}

6766

//****************************************************************************80

6767

6768

void dzror ( int *status, double *x, double *fx, double *xlo,

6769

double *xhi, unsigned long *qleft, unsigned long *qhi )

6770

6771

//****************************************************************************80

6772

6773

// Purpose:

6774

6775

// DZROR seeks the zero of a function using reverse communication.

6776

6777

// Discussion:

6778

6779

// Performs the zero finding. STZROR must have been called before

6780

// this routine in order to set its parameters.

6781

6782

6783

// Arguments

6784

6785

6786

// STATUS <--> At the beginning of a zero finding problem, STATUS

6787

// should be set to 0 and ZROR invoked. (The value

6788

// of other parameters will be ignored on this call.)

6789

6790

// When ZROR needs the function evaluated, it will set

6791

// STATUS to 1 and return. The value of the function

6792

// should be set in FX and ZROR again called without

6793

// changing any of its other parameters.

6794

6795

// When ZROR has finished without error, it will return

6796

// with STATUS 0. In that case (XLO,XHI) bound the answe

6797

6798

// If ZROR finds an error (which implies that F(XLO)-Y an

6799

// F(XHI)-Y have the same sign, it returns STATUS -1. In

6800

// this case, XLO and XHI are undefined.

6801

// INTEGER STATUS

6802

6803

// X <-- The value of X at which F(X) is to be evaluated.

6804

// DOUBLE PRECISION X

6805

6806

// FX --> The value of F(X) calculated when ZROR returns with

6807

// STATUS = 1.

6808

// DOUBLE PRECISION FX

6809

6810

// XLO <-- When ZROR returns with STATUS = 0, XLO bounds the

6811

// inverval in X containing the solution below.

6812

// DOUBLE PRECISION XLO

6813

6814

// XHI <-- When ZROR returns with STATUS = 0, XHI bounds the

6815

// inverval in X containing the solution above.

6816

// DOUBLE PRECISION XHI

6817

6818

// QLEFT <-- .TRUE. if the stepping search terminated unsucessfully

6819

// at XLO. If it is .FALSE. the search terminated

6820

// unsucessfully at XHI.

6821

// QLEFT is LOGICAL

6822

6823

// QHI <-- .TRUE. if F(X) .GT. Y at the termination of the

6824

// search and .FALSE. if F(X) .LT. Y at the

6825

// termination of the search.

6826

// QHI is LOGICAL

6827

6828

6829

{

6830

E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL);

6831

}

6832

//****************************************************************************80

6833

6834

static void E0000 ( int IENTRY, int *status, double *x, double *fx,

6835

unsigned long *qleft, unsigned long *qhi, double *zabsst,

6836

double *zabsto, double *zbig, double *zrelst,

6837

double *zrelto, double *zsmall, double *zstpmu )

6838

6839

//****************************************************************************80

6840

6841

// Purpose:

6842

6843

// E0000 is a reverse-communication zero bounder.

6844

6845

{

6846

# define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz))

6847

6848

static double absstp;

6849

static double abstol;

6850

static double big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi,

6851

xlb,xlo,xsave,xub,yy;

6852

static int i99999;

6853

static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup;

6854

switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;}

6855

DINVR:

6856

if(*status > 0) goto S310;

6857

qcond = !qxmon(small,*x,big);

6858

if(qcond)

6859

{

6860

ftnstop(" SMALL, X, BIG not monotone in INVR");

6861

}

6862

xsave = *x;

6863

6864

// See that SMALL and BIG bound the zero and set QINCR

6865

6866

*x = small;

6867

6868

// GET-FUNCTION-VALUE

6869

6870

i99999 = 1;

6871

goto S300;

6872

S10:

6873

fsmall = *fx;

6874

*x = big;

6875

6876

// GET-FUNCTION-VALUE

6877

6878

i99999 = 2;

6879

goto S300;

6880

S20:

6881

fbig = *fx;

6882

qincr = fbig > fsmall;

6883

if(!qincr) goto S50;

6884

if(fsmall <= 0.0e0) goto S30;

6885

*status = -1;

6886

*qleft = *qhi = 1;

6887

return;

6888

S30:

6889

if(fbig >= 0.0e0) goto S40;

6890

*status = -1;

6891

*qleft = *qhi = 0;

6892

return;

6893

S40:

6894

goto S80;

6895

S50:

6896

if(fsmall >= 0.0e0) goto S60;

6897

*status = -1;

6898

*qleft = 1;

6899

*qhi = 0;

6900

return;

6901

S60:

6902

if(fbig <= 0.0e0) goto S70;

6903

*status = -1;

6904

*qleft = 0;

6905

*qhi = 1;

6906

return;

6907

S80:

6908

S70:

6909

*x = xsave;

6910

step = fifdmax1(absstp,relstp*fabs(*x));

6911

6912

// YY = F(X) - Y

6913

// GET-FUNCTION-VALUE

6914

6915

i99999 = 3;

6916

goto S300;

6917

S90:

6918

yy = *fx;

6919

if(!(yy == 0.0e0)) goto S100;

6920

*status = 0;

6921

qok = 1;

6922

return;

6923

S100:

6924

qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0;

6925

6926

// HANDLE CASE IN WHICH WE MUST STEP HIGHER

6927

6928

if(!qup) goto S170;

6929

xlb = xsave;

6930

xub = fifdmin1(xlb+step,big);

6931

goto S120;

6932

S110:

6933

if(qcond) goto S150;

6934

S120:

6935

6936

// YY = F(XUB) - Y

6937

6938

*x = xub;

6939

6940

// GET-FUNCTION-VALUE

6941

6942

i99999 = 4;

6943

goto S300;

6944

S130:

6945

yy = *fx;

6946

qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0;

6947

qlim = xub >= big;

6948

qcond = qbdd || qlim;

6949

if(qcond) goto S140;

6950

step = stpmul*step;

6951

xlb = xub;

6952

xub = fifdmin1(xlb+step,big);

6953

S140:

6954

goto S110;

6955

S150:

6956

if(!(qlim && !qbdd)) goto S160;

6957

*status = -1;

6958

*qleft = 0;

6959

*qhi = !qincr;

6960

*x = big;

6961

return;

6962

S160:

6963

goto S240;

6964

S170:

6965

6966

// HANDLE CASE IN WHICH WE MUST STEP LOWER

6967

6968

xub = xsave;

6969

xlb = fifdmax1(xub-step,small);

6970

goto S190;

6971

S180:

6972

if(qcond) goto S220;

6973

S190:

6974

6975

// YY = F(XLB) - Y

6976

6977

*x = xlb;

6978

6979

// GET-FUNCTION-VALUE

6980

6981

i99999 = 5;

6982

goto S300;

6983

S200:

6984

yy = *fx;

6985

qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0;

6986

qlim = xlb <= small;

6987

qcond = qbdd || qlim;

6988

if(qcond) goto S210;

6989

step = stpmul*step;

6990

xub = xlb;

6991

xlb = fifdmax1(xub-step,small);

6992

S210:

6993

goto S180;

6994

S220:

6995

if(!(qlim && !qbdd)) goto S230;

6996

*status = -1;

6997

*qleft = 1;

6998

*qhi = qincr;

6999

*x = small;

7000

return;

7001

S240:

7002

S230:

7003

dstzr(&xlb,&xub,&abstol,&reltol);

7004

7005

// IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F.

7006

7007

*status = 0;

7008

goto S260;

7009

S250:

7010

if(!(*status == 1)) goto S290;

7011

S260:

7012

dzror ( status, x, fx, &xlo, &xhi, &qdum1, &qdum2 );

7013

if(!(*status == 1)) goto S280;

7014

7015

// GET-FUNCTION-VALUE

7016

7017

i99999 = 6;

7018

goto S300;

7019

S280:

7020

S270:

7021

goto S250;

7022

S290:

7023

*x = xlo;

7024

*status = 0;

7025

return;

7026

DSTINV:

7027

small = *zsmall;

7028

big = *zbig;

7029

absstp = *zabsst;

7030

relstp = *zrelst;

7031

stpmul = *zstpmu;

7032

abstol = *zabsto;

7033

reltol = *zrelto;

7034

return;

7035

S300:

7036

7037

// TO GET-FUNCTION-VALUE

7038

7039

*status = 1;

7040

return;

7041

S310:

7042

switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case

7043

4: goto S130;case 5: goto S200;case 6: goto S270;default: break;}

7044

# undef qxmon

7045

}

7046

//****************************************************************************80

7047

7048

static void E0001 ( int IENTRY, int *status, double *x, double *fx,

7049

double *xlo, double *xhi, unsigned long *qleft,

7050

unsigned long *qhi, double *zabstl, double *zreltl,

7051

double *zxhi, double *zxlo )

7052

7053

//****************************************************************************80

7054

7055

// Purpose:

7056

7057

// E00001 is a reverse-communication zero finder.

7058

7059

{

7060

# define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx))))

7061

7062

static double a,abstol,b,c,d,fa,fb,fc,fd,fda;

7063

static double fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo;

7064

static int ext,i99999;

7065

static unsigned long first,qrzero;

7066

switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;}

7067

DZROR:

7068

if(*status > 0) goto S280;

7069

*xlo = xxlo;

7070

*xhi = xxhi;

7071

b = *x = *xlo;

7072

7073

// GET-FUNCTION-VALUE

7074

7075

i99999 = 1;

7076

goto S270;

7077

S10:

7078

fb = *fx;

7079

*xlo = *xhi;

7080

a = *x = *xlo;

7081

7082

// GET-FUNCTION-VALUE

7083

7084

i99999 = 2;

7085

goto S270;

7086

S20:

7087

7088

// Check that F(ZXLO) < 0 < F(ZXHI) or

7089

// F(ZXLO) > 0 > F(ZXHI)

7090

7091

if(!(fb < 0.0e0)) goto S40;

7092

if(!(*fx < 0.0e0)) goto S30;

7093

*status = -1;

7094

*qleft = *fx < fb;

7095

*qhi = 0;

7096

return;

7097

S40:

7098

S30:

7099

if(!(fb > 0.0e0)) goto S60;

7100

if(!(*fx > 0.0e0)) goto S50;

7101

*status = -1;

7102

*qleft = *fx > fb;

7103

*qhi = 1;

7104

return;

7105

S60:

7106

S50:

7107

fa = *fx;

7108

first = 1;

7109

S70:

7110

c = a;

7111

fc = fa;

7112

ext = 0;

7113

S80:

7114

if(!(fabs(fc) < fabs(fb))) goto S100;

7115

if(!(c != a)) goto S90;

7116

d = a;

7117

fd = fa;

7118

S90:

7119

a = b;

7120

fa = fb;

7121

*xlo = c;

7122

b = *xlo;

7123

fb = fc;

7124

c = a;

7125

fc = fa;

7126

S100:

7127

tol = ftol(*xlo);

7128

m = (c+b)*.5e0;

7129

mb = m-b;

7130

if(!(fabs(mb) > tol)) goto S240;

7131

if(!(ext > 3)) goto S110;

7132

w = mb;

7133

goto S190;

7134

S110:

7135

tol = fifdsign(tol,mb);

7136

p = (b-a)*fb;

7137

if(!first) goto S120;

7138

q = fa-fb;

7139

first = 0;

7140

goto S130;

7141

S120:

7142

fdb = (fd-fb)/(d-b);

7143

fda = (fd-fa)/(d-a);

7144

p = fda*p;

7145

q = fdb*fa-fda*fb;

7146

S130:

7147

if(!(p < 0.0e0)) goto S140;

7148

p = -p;

7149

q = -q;

7150

S140:

7151

if(ext == 3) p *= 2.0e0;

7152

if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150;

7153

w = tol;

7154

goto S180;

7155

S150:

7156

if(!(p < mb*q)) goto S160;

7157

w = p/q;

7158

goto S170;

7159

S160:

7160

w = mb;

7161

S190:

7162

S180:

7163

S170:

7164

d = a;

7165

fd = fa;

7166

a = b;

7167

fa = fb;

7168

b += w;

7169

*xlo = b;

7170

*x = *xlo;

7171

7172

// GET-FUNCTION-VALUE

7173

7174

i99999 = 3;

7175

goto S270;

7176

S200:

7177

fb = *fx;

7178

if(!(fc*fb >= 0.0e0)) goto S210;

7179

goto S70;

7180

S210:

7181

if(!(w == mb)) goto S220;

7182

ext = 0;

7183

goto S230;

7184

S220:

7185

ext += 1;

7186

S230:

7187

goto S80;

7188

S240:

7189

*xhi = c;

7190

qrzero = fc >= 0.0e0 && fb <= 0.0e0 || fc < 0.0e0 && fb >= 0.0e0;

7191

if(!qrzero) goto S250;

7192

*status = 0;

7193

goto S260;

7194

S250:

7195

*status = -1;

7196

S260:

7197

return;

7198

DSTZR:

7199

xxlo = *zxlo;

7200

xxhi = *zxhi;

7201

abstol = *zabstl;

7202

reltol = *zreltl;

7203

return;

7204

S270:

7205

7206

// TO GET-FUNCTION-VALUE

7207

7208

*status = 1;

7209

return;

7210

S280:

7211

switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200;

7212

default: break;}

7213

# undef ftol

7214

}

7215

//****************************************************************************80

7216

7217

void erf_values ( int *n_data, double *x, double *fx )

7218

7219

//****************************************************************************80

7220

7221

// Purpose:

7222

7223

// ERF_VALUES returns some values of the ERF or "error" function.

7224

7225

// Definition:

7226

7227

// ERF(X) = ( 2 / sqrt ( PI ) * integral ( 0 <= T <= X ) exp ( - T^2 ) dT

7228

7229

// Modified:

7230

7231

// 31 May 2004

7232

7233

// Author:

7234

7235

// John Burkardt

7236

7237

// Reference:

7238

7239

// Milton Abramowitz and Irene Stegun,

7240

// Handbook of Mathematical Functions,

7241

// US Department of Commerce, 1964.

7242

7243

// Parameters:

7244

7245

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

7246

// first call. On each call, the routine increments N_DATA by 1, and

7247

// returns the corresponding data; when there is no more data, the

7248

// output value of N_DATA will be 0 again.

7249

7250

// Output, double *X, the argument of the function.

7251

7252

// Output, double *FX, the value of the function.

7253

7254

{

7255

# define N_MAX 21

7256

7257

double fx_vec[N_MAX] = {

7258

0.0000000000E+00, 0.1124629160E+00, 0.2227025892E+00, 0.3286267595E+00,

7259

0.4283923550E+00, 0.5204998778E+00, 0.6038560908E+00, 0.6778011938E+00,

7260

0.7421009647E+00, 0.7969082124E+00, 0.8427007929E+00, 0.8802050696E+00,

7261

0.9103139782E+00, 0.9340079449E+00, 0.9522851198E+00, 0.9661051465E+00,

7262

0.9763483833E+00, 0.9837904586E+00, 0.9890905016E+00, 0.9927904292E+00,

7263

0.9953222650E+00 };

7264

double x_vec[N_MAX] = {

7265

0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00,

7266

0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00,

7267

0.8E+00, 0.9E+00, 1.0E+00, 1.1E+00,

7268

1.2E+00, 1.3E+00, 1.4E+00, 1.5E+00,

7269

1.6E+00, 1.7E+00, 1.8E+00, 1.9E+00,

7270

2.0E+00 };

7271

7272

if ( *n_data < 0 )

7273

{

7274

*n_data = 0;

7275

}

7276

7277

*n_data = *n_data + 1;

7278

7279

if ( N_MAX < *n_data )

7280

{

7281

*n_data = 0;

7282

*x = 0.0E+00;

7283

*fx = 0.0E+00;

7284

}

7285

else

7286

{

7287

*x = x_vec[*n_data-1];

7288

*fx = fx_vec[*n_data-1];

7289

}

7290

return;

7291

# undef N_MAX

7292

}

7293

//****************************************************************************80

7294

7295

double error_f ( double *x )

7296

7297

//****************************************************************************80

7298

7299

// Purpose:

7300

7301

// ERROR_F evaluates the error function ERF.

7302

7303

// Parameters:

7304

7305

// Input, double *X, the argument.

7306

7307

// Output, double ERROR_F, the value of the error function at X.

7308

7309

{

7310

static double c = .564189583547756e0;

7311

static double a[5] = {

7312

.771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,

7313

.479137145607681e-01,.128379167095513e+00

7314

};

7315

static double b[3] = {

7316

.301048631703895e-02,.538971687740286e-01,.375795757275549e+00

7317

};

7318

static double p[8] = {

7319

-1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,

7320

4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,

7321

4.51918953711873e+02,3.00459261020162e+02

7322

};

7323

static double q[8] = {

7324

1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,

7325

2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,

7326

7.90950925327898e+02,3.00459260956983e+02

7327

};

7328

static double r[5] = {

7329

2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,

7330

4.65807828718470e+00,2.82094791773523e-01

7331

};

7332

static double s[4] = {

7333

9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,

7334

1.80124575948747e+01

7335

};

7336

static double erf1,ax,bot,t,top,x2;

7337

7338

ax = fabs(*x);

7339

if(ax > 0.5e0) goto S10;

7340

t = *x**x;

7341

top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;

7342

bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;

7343

erf1 = *x*(top/bot);

7344

return erf1;

7345

S10:

7346

if(ax > 4.0e0) goto S20;

7347

top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[

7348

7];

7349

bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[

7350

7];

7351

erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot);

7352

if(*x < 0.0e0) erf1 = -erf1;

7353

return erf1;

7354

S20:

7355

if(ax >= 5.8e0) goto S30;

7356

x2 = *x**x;

7357

t = 1.0e0/x2;

7358

top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];

7359

bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;

7360

erf1 = (c-top/(x2*bot))/ax;

7361

erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1);

7362

if(*x < 0.0e0) erf1 = -erf1;

7363

return erf1;

7364

S30:

7365

erf1 = fifdsign(1.0e0,*x);

7366

return erf1;

7367

}

7368

//****************************************************************************80

7369

7370

double error_fc ( int *ind, double *x )

7371

7372

//****************************************************************************80

7373

7374

// Purpose:

7375

7376

// ERROR_FC evaluates the complementary error function ERFC.

7377

7378

// Modified:

7379

7380

// 09 December 1999

7381

7382

// Parameters:

7383

7384

// Input, int *IND, chooses the scaling.

7385

// If IND is nonzero, then the value returned has been multiplied by

7386

// EXP(X*X).

7387

7388

// Input, double *X, the argument of the function.

7389

7390

// Output, double ERROR_FC, the value of the complementary

7391

// error function.

7392

7393

{

7394

static double c = .564189583547756e0;

7395

static double a[5] = {

7396

.771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,

7397

.479137145607681e-01,.128379167095513e+00

7398

};

7399

static double b[3] = {

7400

.301048631703895e-02,.538971687740286e-01,.375795757275549e+00

7401

};

7402

static double p[8] = {

7403

-1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,

7404

4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,

7405

4.51918953711873e+02,3.00459261020162e+02

7406

};

7407

static double q[8] = {

7408

1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,

7409

2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,

7410

7.90950925327898e+02,3.00459260956983e+02

7411

};

7412

static double r[5] = {

7413

2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,

7414

4.65807828718470e+00,2.82094791773523e-01

7415

};

7416

static double s[4] = {

7417

9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,

7418

1.80124575948747e+01

7419

};

7420

static int K1 = 1;

7421

static double erfc1,ax,bot,e,t,top,w;

7422

7423

7424

// ABS(X) .LE. 0.5

7425

7426

ax = fabs(*x);

7427

if(ax > 0.5e0) goto S10;

7428

t = *x**x;

7429

top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;

7430

bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;

7431

erfc1 = 0.5e0+(0.5e0-*x*(top/bot));

7432

if(*ind != 0) erfc1 = exp(t)*erfc1;

7433

return erfc1;

7434

S10:

7435

7436

// 0.5 .LT. ABS(X) .LE. 4

7437

7438

if(ax > 4.0e0) goto S20;

7439

top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[

7440

7];

7441

bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[

7442

7];

7443

erfc1 = top/bot;

7444

goto S40;

7445

S20:

7446

7447

// ABS(X) .GT. 4

7448

7449

if(*x <= -5.6e0) goto S60;

7450

if(*ind != 0) goto S30;

7451

if(*x > 100.0e0) goto S70;

7452

if(*x**x > -exparg(&K1)) goto S70;

7453

S30:

7454

t = pow(1.0e0/ *x,2.0);

7455

top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];

7456

bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;

7457

erfc1 = (c-t*top/bot)/ax;

7458

S40:

7459

7460

// FINAL ASSEMBLY

7461

7462

if(*ind == 0) goto S50;

7463

if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1;

7464

return erfc1;

7465

S50:

7466

w = *x**x;

7467

t = w;

7468

e = w-t;

7469

erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1;

7470

if(*x < 0.0e0) erfc1 = 2.0e0-erfc1;

7471

return erfc1;

7472

S60:

7473

7474

// LIMIT VALUE FOR LARGE NEGATIVE X

7475

7476

erfc1 = 2.0e0;

7477

if(*ind != 0) erfc1 = 2.0e0*exp(*x**x);

7478

return erfc1;

7479

S70:

7480

7481

// LIMIT VALUE FOR LARGE POSITIVE X

7482

// WHEN IND = 0

7483

7484

erfc1 = 0.0e0;

7485

return erfc1;

7486

}

7487

//****************************************************************************80

7488

7489

double esum ( int *mu, double *x )

7490

7491

//****************************************************************************80

7492

7493

// Purpose:

7494

7495

// ESUM evaluates exp ( MU + X ).

7496

7497

// Parameters:

7498

7499

// Input, int *MU, part of the argument.

7500

7501

// Input, double *X, part of the argument.

7502

7503

// Output, double ESUM, the value of exp ( MU + X ).

7504

7505

{

7506

static double esum,w;

7507

7508

if(*x > 0.0e0) goto S10;

7509

if(*mu < 0) goto S20;

7510

w = (double)*mu+*x;

7511

if(w > 0.0e0) goto S20;

7512

esum = exp(w);

7513

return esum;

7514

S10:

7515

if(*mu > 0) goto S20;

7516

w = (double)*mu+*x;

7517

if(w < 0.0e0) goto S20;

7518

esum = exp(w);

7519

return esum;

7520

S20:

7521

w = *mu;

7522

esum = exp(w)*exp(*x);

7523

return esum;

7524

}

7525

//****************************************************************************80

7526

7527

double eval_pol ( double a[], int *n, double *x )

7528

7529

//****************************************************************************80

7530

7531

// Purpose:

7532

7533

// EVAL_POL evaluates a polynomial at X.

7534

7535

// Discussion:

7536

7537

// EVAL_POL = A(0) + A(1)*X + ... + A(N)*X**N

7538

7539

// Modified:

7540

7541

// 15 December 1999

7542

7543

// Parameters:

7544

7545

// Input, double precision A(0:N), coefficients of the polynomial.

7546

7547

// Input, int *N, length of A.

7548

7549

// Input, double *X, the point at which the polynomial

7550

// is to be evaluated.

7551

7552

// Output, double EVAL_POL, the value of the polynomial at X.

7553

7554

{

7555

static double devlpl,term;

7556

static int i;

7557

7558

term = a[*n-1];

7559

for ( i = *n-1-1; i >= 0; i-- )

7560

{

7561

term = a[i]+term**x;

7562

}

7563

7564

devlpl = term;

7565

return devlpl;

7566

}

7567

//****************************************************************************80

7568

7569

double exparg ( int *l )

7570

7571

//****************************************************************************80

7572

7573

// Purpose:

7574

7575

// EXPARG returns the largest or smallest legal argument for EXP.

7576

7577

// Discussion:

7578

7579

// Only an approximate limit for the argument of EXP is desired.

7580

7581

// Modified:

7582

7583

// 09 December 1999

7584

7585

// Parameters:

7586

7587

// Input, int *L, indicates which limit is desired.

7588

// If L = 0, then the largest positive argument for EXP is desired.

7589

// Otherwise, the largest negative argument for EXP for which the

7590

// result is nonzero is desired.

7591

7592

// Output, double EXPARG, the desired value.

7593

7594

{

7595

static int K1 = 4;

7596

static int K2 = 9;

7597

static int K3 = 10;

7598

static double exparg,lnb;

7599

static int b,m;

7600

7601

b = ipmpar(&K1);

7602

if(b != 2) goto S10;

7603

lnb = .69314718055995e0;

7604

goto S40;

7605

S10:

7606

if(b != 8) goto S20;

7607

lnb = 2.0794415416798e0;

7608

goto S40;

7609

S20:

7610

if(b != 16) goto S30;

7611

lnb = 2.7725887222398e0;

7612

goto S40;

7613

S30:

7614

lnb = log((double)b);

7615

S40:

7616

if(*l == 0) goto S50;

7617

m = ipmpar(&K2)-1;

7618

exparg = 0.99999e0*((double)m*lnb);

7619

return exparg;

7620

S50:

7621

m = ipmpar(&K3);

7622

exparg = 0.99999e0*((double)m*lnb);

7623

return exparg;

7624

}

7625

//****************************************************************************80

7626

7627

void f_cdf_values ( int *n_data, int *a, int *b, double *x, double *fx )

7628

7629

//****************************************************************************80

7630

7631

// Purpose:

7632

7633

// F_CDF_VALUES returns some values of the F CDF test function.

7634

7635

// Discussion:

7636

7637

// The value of F_CDF ( DFN, DFD, X ) can be evaluated in Mathematica by

7638

// commands like:

7639

7640

// Needs["Statistics`ContinuousDistributions`"]

7641

// CDF[FRatioDistribution[ DFN, DFD ], X ]

7642

7643

// Modified:

7644

7645

// 11 June 2004

7646

7647

// Author:

7648

7649

// John Burkardt

7650

7651

// Reference:

7652

7653

// Milton Abramowitz and Irene Stegun,

7654

// Handbook of Mathematical Functions,

7655

// US Department of Commerce, 1964.

7656

7657

// Stephen Wolfram,

7658

// The Mathematica Book,

7659

// Fourth Edition,

7660

// Wolfram Media / Cambridge University Press, 1999.

7661

7662

// Parameters:

7663

7664

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

7665

// first call. On each call, the routine increments N_DATA by 1, and

7666

// returns the corresponding data; when there is no more data, the

7667

// output value of N_DATA will be 0 again.

7668

7669

// Output, int *A, int *B, the parameters of the function.

7670

7671

// Output, double *X, the argument of the function.

7672

7673

// Output, double *FX, the value of the function.

7674

7675

{

7676

# define N_MAX 20

7677

7678

int a_vec[N_MAX] = {

7679

1, 1, 5, 1,

7680

2, 4, 1, 6,

7681

8, 1, 3, 6,

7682

1, 1, 1, 1,

7683

2, 3, 4, 5 };

7684

int b_vec[N_MAX] = {

7685

1, 5, 1, 5,

7686

10, 20, 5, 6,

7687

16, 5, 10, 12,

7688

5, 5, 5, 5,

7689

5, 5, 5, 5 };

7690

double fx_vec[N_MAX] = {

7691

0.500000E+00, 0.499971E+00, 0.499603E+00, 0.749699E+00,

7692

0.750466E+00, 0.751416E+00, 0.899987E+00, 0.899713E+00,

7693

0.900285E+00, 0.950025E+00, 0.950057E+00, 0.950193E+00,

7694

0.975013E+00, 0.990002E+00, 0.994998E+00, 0.999000E+00,

7695

0.568799E+00, 0.535145E+00, 0.514343E+00, 0.500000E+00 };

7696

double x_vec[N_MAX] = {

7697

1.00E+00, 0.528E+00, 1.89E+00, 1.69E+00,

7698

1.60E+00, 1.47E+00, 4.06E+00, 3.05E+00,

7699

2.09E+00, 6.61E+00, 3.71E+00, 3.00E+00,

7700

10.01E+00, 16.26E+00, 22.78E+00, 47.18E+00,

7701

1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00 };

7702

7703

if ( *n_data < 0 )

7704

{

7705

*n_data = 0;

7706

}

7707

7708

*n_data = *n_data + 1;

7709

7710

if ( N_MAX < *n_data )

7711

{

7712

*n_data = 0;

7713

*a = 0;

7714

*b = 0;

7715

*x = 0.0E+00;

7716

*fx = 0.0E+00;

7717

}

7718

else

7719

{

7720

*a = a_vec[*n_data-1];

7721

*b = b_vec[*n_data-1];

7722

*x = x_vec[*n_data-1];

7723

*fx = fx_vec[*n_data-1];

7724

}

7725

return;

7726

# undef N_MAX

7727

}

7728

//****************************************************************************80

7729

7730

void f_noncentral_cdf_values ( int *n_data, int *a, int *b, double *lambda,

7731

double *x, double *fx )

7732

7733

//****************************************************************************80

7734

7735

// Purpose:

7736

7737

// F_NONCENTRAL_CDF_VALUES returns some values of the F CDF test function.

7738

7739

// Discussion:

7740

7741

// The value of NONCENTRAL_F_CDF ( DFN, DFD, LAMDA, X ) can be evaluated

7742

// in Mathematica by commands like:

7743

7744

// Needs["Statistics`ContinuousDistributions`"]

7745

// CDF[NoncentralFRatioDistribution[ DFN, DFD, LAMBDA ], X ]

7746

7747

// Modified:

7748

7749

// 12 June 2004

7750

7751

// Author:

7752

7753

// John Burkardt

7754

7755

// Reference:

7756

7757

// Milton Abramowitz and Irene Stegun,

7758

// Handbook of Mathematical Functions,

7759

// US Department of Commerce, 1964.

7760

7761

// Stephen Wolfram,

7762

// The Mathematica Book,

7763

// Fourth Edition,

7764

// Wolfram Media / Cambridge University Press, 1999.

7765

7766

// Parameters:

7767

7768

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

7769

// first call. On each call, the routine increments N_DATA by 1, and

7770

// returns the corresponding data; when there is no more data, the

7771

// output value of N_DATA will be 0 again.

7772

7773

// Output, int *A, int *B, double *LAMBDA, the

7774

// parameters of the function.

7775

7776

// Output, double *X, the argument of the function.

7777

7778

// Output, double *FX, the value of the function.

7779

7780

{

7781

# define N_MAX 22

7782

7783

int a_vec[N_MAX] = {

7784

1, 1, 1, 1,

7785

1, 1, 1, 1,

7786

1, 1, 2, 2,

7787

3, 3, 4, 4,

7788

5, 5, 6, 6,

7789

8, 16 };

7790

int b_vec[N_MAX] = {

7791

1, 5, 5, 5,

7792

5, 5, 5, 5,

7793

5, 5, 5, 10,

7794

5, 5, 5, 5,

7795

1, 5, 6, 12,

7796

16, 8 };

7797

double fx_vec[N_MAX] = {

7798

0.500000E+00, 0.636783E+00, 0.584092E+00, 0.323443E+00,

7799

0.450119E+00, 0.607888E+00, 0.705928E+00, 0.772178E+00,

7800

0.819105E+00, 0.317035E+00, 0.432722E+00, 0.450270E+00,

7801

0.426188E+00, 0.337744E+00, 0.422911E+00, 0.692767E+00,

7802

0.363217E+00, 0.421005E+00, 0.426667E+00, 0.446402E+00,

7803

0.844589E+00, 0.816368E+00 };

7804

double lambda_vec[N_MAX] = {

7805

0.00E+00, 0.000E+00, 0.25E+00, 1.00E+00,

7806

1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,

7807

1.00E+00, 2.00E+00, 1.00E+00, 1.00E+00,

7808

1.00E+00, 2.00E+00, 1.00E+00, 1.00E+00,

7809

0.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,

7810

1.00E+00, 1.00E+00 };

7811

double x_vec[N_MAX] = {

7812

1.00E+00, 1.00E+00, 1.00E+00, 0.50E+00,

7813

1.00E+00, 2.00E+00, 3.00E+00, 4.00E+00,

7814

5.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,

7815

1.00E+00, 1.00E+00, 1.00E+00, 2.00E+00,

7816

1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,

7817

2.00E+00, 2.00E+00 };

7818

7819

if ( *n_data < 0 )

7820

{

7821

*n_data = 0;

7822

}

7823

7824

*n_data = *n_data + 1;

7825

7826

if ( N_MAX < *n_data )

7827

{

7828

*n_data = 0;

7829

*a = 0;

7830

*b = 0;

7831

*lambda = 0.0E+00;

7832

*x = 0.0E+00;

7833

*fx = 0.0E+00;

7834

}

7835

else

7836

{

7837

*a = a_vec[*n_data-1];

7838

*b = b_vec[*n_data-1];

7839

*lambda = lambda_vec[*n_data-1];

7840

*x = x_vec[*n_data-1];

7841

*fx = fx_vec[*n_data-1];

7842

}

7843

7844

return;

7845

# undef N_MAX

7846

}

7847

//****************************************************************************80

7848

7849

double fifdint ( double a )

7850

7851

//****************************************************************************80

7852

7853

// Purpose:

7854

7855

// FIFDINT truncates a double number to an integer.

7856

7857

// Parameters:

7858

7859

// a - number to be truncated

7860

{

7861

return (double) ((int) a);

7862

}

7863

//****************************************************************************80

7864

7865

double fifdmax1 ( double a, double b )

7866

7867

//****************************************************************************80

7868

7869

// Purpose:

7870

7871

// FIFDMAX1 returns the maximum of two numbers a and b

7872

7873

// Parameters:

7874

7875

// a - first number

7876

// b - second number

7877

7878

{

7879

if ( a < b )

7880

{

7881

return b;

7882

}

7883

else

7884

{

7885

return a;

7886

}

7887

}

7888

//****************************************************************************80

7889

7890

double fifdmin1 ( double a, double b )

7891

7892

//****************************************************************************80

7893

7894

// Purpose:

7895

7896

// FIFDMIN1 returns the minimum of two numbers.

7897

7898

// Parameters:

7899

7900

// a - first number

7901

// b - second number

7902

7903

{

7904

if (a < b) return a;

7905

else return b;

7906

}

7907

//****************************************************************************80

7908

7909

double fifdsign ( double mag, double sign )

7910

7911

//****************************************************************************80

7912

7913

// Purpose:

7914

7915

// FIFDSIGN transfers the sign of the variable "sign" to the variable "mag"

7916

7917

// Parameters:

7918

7919

// mag - magnitude

7920

// sign - sign to be transfered

7921

7922

{

7923

if (mag < 0) mag = -mag;

7924

if (sign < 0) mag = -mag;

7925

return mag;

7926

7927

}

7928

//****************************************************************************80

7929

7930

long fifidint ( double a )

7931

7932

//****************************************************************************80

7933

7934

// Purpose:

7935

7936

// FIFIDINT truncates a double number to a long integer

7937

7938

// Parameters:

7939

7940

// a - number to be truncated

7941

7942

{

7943

if ( a < 1.0 )

7944

{

7945

return (long) 0;

7946

}

7947

else

7948

{

7949

return ( long ) a;

7950

}

7951

}

7952

//****************************************************************************80

7953

7954

long fifmod ( long a, long b )

7955

7956

//****************************************************************************80

7957

7958

// Purpose:

7959

7960

// FIFMOD returns the modulo of a and b

7961

7962

// Parameters:

7963

7964

// a - numerator

7965

// b - denominator

7966

7967

{

7968

return ( a % b );

7969

}

7970

//****************************************************************************80

7971

7972

double fpser ( double *a, double *b, double *x, double *eps )

7973

7974

//****************************************************************************80

7975

7976

// Purpose:

7977

7978

// FPSER evaluates IX(A,B)(X) for very small B.

7979

7980

// Discussion:

7981

7982

// This routine is appropriate for use when

7983

7984

// B < min ( EPS, EPS * A )

7985

7986

// and

7987

7988

// X <= 0.5.

7989

7990

// Parameters:

7991

7992

// Input, double *A, *B, parameters of the function.

7993

7994

// Input, double *X, the point at which the function is to

7995

// be evaluated.

7996

7997

// Input, double *EPS, a tolerance.

7998

7999

// Output, double FPSER, the value of IX(A,B)(X).

8000

8001

{

8002

static int K1 = 1;

8003

static double fpser,an,c,s,t,tol;

8004

8005

fpser = 1.0e0;

8006

if(*a <= 1.e-3**eps) goto S10;

8007

fpser = 0.0e0;

8008

t = *a*log(*x);

8009

if(t < exparg(&K1)) return fpser;

8010

fpser = exp(t);

8011

S10:

8012

8013

// NOTE THAT 1/B(A,B) = B

8014

8015

fpser = *b/ *a*fpser;

8016

tol = *eps/ *a;

8017

an = *a+1.0e0;

8018

t = *x;

8019

s = t/an;

8020

S20:

8021

an += 1.0e0;

8022

t = *x*t;

8023

c = t/an;

8024

s += c;

8025

if(fabs(c) > tol) goto S20;

8026

fpser *= (1.0e0+*a*s);

8027

return fpser;

8028

}

8029

//****************************************************************************80

8030

8031

void ftnstop ( string msg )

8032

8033

//****************************************************************************80

8034

8035

// Purpose:

8036

8037

// FTNSTOP prints a message to standard error and then exits.

8038

8039

// Parameters:

8040

8041

// Input, string MSG, the message to be printed.

8042

8043

{

8044

cerr << msg << "\n";

8045

8046

exit ( 0 );

8047

}

8048

//****************************************************************************80

8049

8050

double gam1 ( double *a )

8051

8052

//****************************************************************************80

8053

8054

// Purpose:

8055

8056

// GAM1 computes 1 / GAMMA(A+1) - 1 for -0.5D+00 <= A <= 1.5

8057

8058

// Parameters:

8059

8060

// Input, double *A, forms the argument of the Gamma function.

8061

8062

// Output, double GAM1, the value of 1 / GAMMA ( A + 1 ) - 1.

8063

8064

{

8065

static double s1 = .273076135303957e+00;

8066

static double s2 = .559398236957378e-01;

8067

static double p[7] = {

8068

.577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00,

8069

.597275330452234e-01,.766968181649490e-02,-.514889771323592e-02,

8070

.589597428611429e-03

8071

};

8072

static double q[5] = {

8073

.100000000000000e+01,.427569613095214e+00,.158451672430138e+00,

8074

.261132021441447e-01,.423244297896961e-02

8075

};

8076

static double r[9] = {

8077

-.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00,

8078

.118378989872749e+00,.930357293360349e-03,-.118290993445146e-01,

8079

.223047661158249e-02,.266505979058923e-03,-.132674909766242e-03

8080

};

8081

static double gam1,bot,d,t,top,w,T1;

8082

8083

t = *a;

8084

d = *a-0.5e0;

8085

if(d > 0.0e0) t = d-0.5e0;

8086

T1 = t;

8087

if(T1 < 0) goto S40;

8088

else if(T1 == 0) goto S10;

8089

else goto S20;

8090

S10:

8091

gam1 = 0.0e0;

8092

return gam1;

8093

S20:

8094

top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0];

8095

bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0;

8096

w = top/bot;

8097

if(d > 0.0e0) goto S30;

8098

gam1 = *a*w;

8099

return gam1;

8100

S30:

8101

gam1 = t/ *a*(w-0.5e0-0.5e0);

8102

return gam1;

8103

S40:

8104

top = (((((((r[8]*t+r[7])*t+r[6])*t+r[5])*t+r[4])*t+r[3])*t+r[2])*t+r[1])*t+

8105

r[0];

8106

bot = (s2*t+s1)*t+1.0e0;

8107

w = top/bot;

8108

if(d > 0.0e0) goto S50;

8109

gam1 = *a*(w+0.5e0+0.5e0);

8110

return gam1;

8111

S50:

8112

gam1 = t*w/ *a;

8113

return gam1;

8114

}

8115

//****************************************************************************80

8116

8117

void gamma_inc ( double *a, double *x, double *ans, double *qans, int *ind )

8118

8119

//****************************************************************************80

8120

8121

// Purpose:

8122

8123

// GAMMA_INC evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).

8124

8125

// Discussion:

8126

8127

// This is certified spaghetti code.

8128

8129

// Author:

8130

8131

// Alfred H Morris, Jr,

8132

// Naval Surface Weapons Center,

8133

// Dahlgren, Virginia.

8134

8135

// Parameters:

8136

8137

// Input, double *A, *X, the arguments of the incomplete

8138

// gamma ratio. A and X must be nonnegative. A and X cannot

8139

// both be zero.

8140

8141

// Output, double *ANS, *QANS. On normal output,

8142

// ANS = P(A,X) and QANS = Q(A,X). However, ANS is set to 2 if

8143

// A or X is negative, or both are 0, or when the answer is

8144

// computationally indeterminate because A is extremely large

8145

// and X is very close to A.

8146

8147

// Input, int *IND, indicates the accuracy request:

8148

// 0, as much accuracy as possible.

8149

// 1, to within 1 unit of the 6-th significant digit,

8150

// otherwise, to within 1 unit of the 3rd significant digit.

8151

8152

{

8153

static double alog10 = 2.30258509299405e0;

8154

static double d10 = -.185185185185185e-02;

8155

static double d20 = .413359788359788e-02;

8156

static double d30 = .649434156378601e-03;

8157

static double d40 = -.861888290916712e-03;

8158

static double d50 = -.336798553366358e-03;

8159

static double d60 = .531307936463992e-03;

8160

static double d70 = .344367606892378e-03;

8161

static double rt2pin = .398942280401433e0;

8162

static double rtpi = 1.77245385090552e0;

8163

static double third = .333333333333333e0;

8164

static double acc0[3] = {

8165

5.e-15,5.e-7,5.e-4

8166

};

8167

static double big[3] = {

8168

20.0e0,14.0e0,10.0e0

8169

};

8170

static double d0[13] = {

8171

.833333333333333e-01,-.148148148148148e-01,.115740740740741e-02,

8172

.352733686067019e-03,-.178755144032922e-03,.391926317852244e-04,

8173

-.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06,

8174

-.176659527368261e-06,.670785354340150e-08,.102618097842403e-07,

8175

-.438203601845335e-08

8176

};

8177

static double d1[12] = {

8178

-.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03,

8179

.205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04,

8180

.764916091608111e-05,-.161209008945634e-05,.464712780280743e-08,

8181

.137863344691572e-06,-.575254560351770e-07,.119516285997781e-07

8182

};

8183

static double d2[10] = {

8184

-.268132716049383e-02,.771604938271605e-03,.200938786008230e-05,

8185

-.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04,

8186

.342357873409614e-07,.137219573090629e-05,-.629899213838006e-06,

8187

.142806142060642e-06

8188

};

8189

static double d3[8] = {

8190

.229472093621399e-03,-.469189494395256e-03,.267720632062839e-03,

8191

-.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04,

8192

-.567495282699160e-05,.142309007324359e-05

8193

};

8194

static double d4[6] = {

8195

.784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05,

8196

.664149821546512e-04,-.396836504717943e-04,.113757269706784e-04

8197

};

8198

static double d5[4] = {

8199

-.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03,

8200

.679778047793721e-04

8201

};

8202

static double d6[2] = {

8203

-.592166437353694e-03,.270878209671804e-03

8204

};

8205

static double e00[3] = {

8206

.25e-3,.25e-1,.14e0

8207

};

8208

static double x00[3] = {

8209

31.0e0,17.0e0,9.7e0

8210

};

8211

static int K1 = 1;

8212

static int K2 = 0;

8213

static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6,

8214

cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z;

8215

static int i,iop,m,max,n;

8216

static double wk[20],T3;

8217

static int T4,T5;

8218

static double T6,T7;

8219

8220

8221

// E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST

8222

// NUMBER FOR WHICH 1.0 + E .GT. 1.0 .

8223

8224

e = dpmpar(&K1);

8225

if(*a < 0.0e0 || *x < 0.0e0) goto S430;

8226

if(*a == 0.0e0 && *x == 0.0e0) goto S430;

8227

if(*a**x == 0.0e0) goto S420;

8228

iop = *ind+1;

8229

if(iop != 1 && iop != 2) iop = 3;

8230

acc = fifdmax1(acc0[iop-1],e);

8231

e0 = e00[iop-1];

8232

x0 = x00[iop-1];

8233

8234

// SELECT THE APPROPRIATE ALGORITHM

8235

8236

if(*a >= 1.0e0) goto S10;

8237

if(*a == 0.5e0) goto S390;

8238

if(*x < 1.1e0) goto S160;

8239

t1 = *a*log(*x)-*x;

8240

u = *a*exp(t1);

8241

if(u == 0.0e0) goto S380;

8242

r = u*(1.0e0+gam1(a));

8243

goto S250;

8244

S10:

8245

if(*a >= big[iop-1]) goto S30;

8246

if(*a > *x || *x >= x0) goto S20;

8247

twoa = *a+*a;

8248

m = fifidint(twoa);

8249

if(twoa != (double)m) goto S20;

8250

i = m/2;

8251

if(*a == (double)i) goto S210;

8252

goto S220;

8253

S20:

8254

t1 = *a*log(*x)-*x;

8255

r = exp(t1)/ gamma_x(a);

8256

goto S40;

8257

S30:

8258

l = *x/ *a;

8259

if(l == 0.0e0) goto S370;

8260

s = 0.5e0+(0.5e0-l);

8261

z = rlog(&l);

8262

if(z >= 700.0e0/ *a) goto S410;

8263

y = *a*z;

8264

rta = sqrt(*a);

8265

if(fabs(s) <= e0/rta) goto S330;

8266

if(fabs(s) <= 0.4e0) goto S270;

8267

t = pow(1.0e0/ *a,2.0);

8268

t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);

8269

t1 -= y;

8270

r = rt2pin*rta*exp(t1);

8271

S40:

8272

if(r == 0.0e0) goto S420;

8273

if(*x <= fifdmax1(*a,alog10)) goto S50;

8274

if(*x < x0) goto S250;

8275

goto S100;

8276

S50:

8277

8278

// TAYLOR SERIES FOR P/R

8279

8280

apn = *a+1.0e0;

8281

t = *x/apn;

8282

wk[0] = t;

8283

for ( n = 2; n <= 20; n++ )

8284

{

8285

apn += 1.0e0;

8286

t *= (*x/apn);

8287

if(t <= 1.e-3) goto S70;

8288

wk[n-1] = t;

8289

}

8290

n = 20;

8291

S70:

8292

sum = t;

8293

tol = 0.5e0*acc;

8294

S80:

8295

apn += 1.0e0;

8296

t *= (*x/apn);

8297

sum += t;

8298

if(t > tol) goto S80;

8299

max = n-1;

8300

for ( m = 1; m <= max; m++ )

8301

{

8302

n -= 1;

8303

sum += wk[n-1];

8304

}

8305

*ans = r/ *a*(1.0e0+sum);

8306

*qans = 0.5e0+(0.5e0-*ans);

8307

return;

8308

S100:

8309

8310

// ASYMPTOTIC EXPANSION

8311

8312

amn = *a-1.0e0;

8313

t = amn/ *x;

8314

wk[0] = t;

8315

for ( n = 2; n <= 20; n++ )

8316

{

8317

amn -= 1.0e0;

8318

t *= (amn/ *x);

8319

if(fabs(t) <= 1.e-3) goto S120;

8320

wk[n-1] = t;

8321

}

8322

n = 20;

8323

S120:

8324

sum = t;

8325

S130:

8326

if(fabs(t) <= acc) goto S140;

8327

amn -= 1.0e0;

8328

t *= (amn/ *x);

8329

sum += t;

8330

goto S130;

8331

S140:

8332

max = n-1;

8333

for ( m = 1; m <= max; m++ )

8334

{

8335

n -= 1;

8336

sum += wk[n-1];

8337

}

8338

*qans = r/ *x*(1.0e0+sum);

8339

*ans = 0.5e0+(0.5e0-*qans);

8340

return;

8341

S160:

8342

8343

// TAYLOR SERIES FOR P(A,X)/X**A

8344

8345

an = 3.0e0;

8346

c = *x;

8347

sum = *x/(*a+3.0e0);

8348

tol = 3.0e0*acc/(*a+1.0e0);

8349

S170:

8350

an += 1.0e0;

8351

c = -(c*(*x/an));

8352

t = c/(*a+an);

8353

sum += t;

8354

if(fabs(t) > tol) goto S170;

8355

j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));

8356

z = *a*log(*x);

8357

h = gam1(a);

8358

g = 1.0e0+h;

8359

if(*x < 0.25e0) goto S180;

8360

if(*a < *x/2.59e0) goto S200;

8361

goto S190;

8362

S180:

8363

if(z > -.13394e0) goto S200;

8364

S190:

8365

w = exp(z);

8366

*ans = w*g*(0.5e0+(0.5e0-j));

8367

*qans = 0.5e0+(0.5e0-*ans);

8368

return;

8369

S200:

8370

l = rexp(&z);

8371

w = 0.5e0+(0.5e0+l);

8372

*qans = (w*j-l)*g-h;

8373

if(*qans < 0.0e0) goto S380;

8374

*ans = 0.5e0+(0.5e0-*qans);

8375

return;

8376

S210:

8377

8378

// FINITE SUMS FOR Q WHEN A .GE. 1 AND 2*A IS AN INTEGER

8379

8380

sum = exp(-*x);

8381

t = sum;

8382

n = 1;

8383

c = 0.0e0;

8384

goto S230;

8385

S220:

8386

rtx = sqrt(*x);

8387

sum = error_fc ( &K2, &rtx );

8388

t = exp(-*x)/(rtpi*rtx);

8389

n = 0;

8390

c = -0.5e0;

8391

S230:

8392

if(n == i) goto S240;

8393

n += 1;

8394

c += 1.0e0;

8395

t = *x*t/c;

8396

sum += t;

8397

goto S230;

8398

S240:

8399

*qans = sum;

8400

*ans = 0.5e0+(0.5e0-*qans);

8401

return;

8402

S250:

8403

8404

// CONTINUED FRACTION EXPANSION

8405

8406

tol = fifdmax1(5.0e0*e,acc);

8407

a2nm1 = a2n = 1.0e0;

8408

b2nm1 = *x;

8409

b2n = *x+(1.0e0-*a);

8410

c = 1.0e0;

8411

S260:

8412

a2nm1 = *x*a2n+c*a2nm1;

8413

b2nm1 = *x*b2n+c*b2nm1;

8414

am0 = a2nm1/b2nm1;

8415

c += 1.0e0;

8416

cma = c-*a;

8417

a2n = a2nm1+cma*a2n;

8418

b2n = b2nm1+cma*b2n;

8419

an0 = a2n/b2n;

8420

if(fabs(an0-am0) >= tol*an0) goto S260;

8421

*qans = r*an0;

8422

*ans = 0.5e0+(0.5e0-*qans);

8423

return;

8424

S270:

8425

8426

// GENERAL TEMME EXPANSION

8427

8428

if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430;

8429

c = exp(-y);

8430

T3 = sqrt(y);

8431

w = 0.5e0 * error_fc ( &K1, &T3 );

8432

u = 1.0e0/ *a;

8433

z = sqrt(z+z);

8434

if(l < 1.0e0) z = -z;

8435

T4 = iop-2;

8436

if(T4 < 0) goto S280;

8437

else if(T4 == 0) goto S290;

8438

else goto S300;

8439

S280:

8440

if(fabs(s) <= 1.e-3) goto S340;

8441

c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[

8442

6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;

8443

c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5]

8444

)*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;

8445

c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+

8446

d2[2])*z+d2[1])*z+d2[0])*z+d20;

8447

c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+

8448

d3[0])*z+d30;

8449

c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40;

8450

c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50;

8451

c6 = (d6[1]*z+d6[0])*z+d60;

8452

t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;

8453

goto S310;

8454

S290:

8455

c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;

8456

c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;

8457

c2 = d2[0]*z+d20;

8458

t = (c2*u+c1)*u+c0;

8459

goto S310;

8460

S300:

8461

t = ((d0[2]*z+d0[1])*z+d0[0])*z-third;

8462

S310:

8463

if(l < 1.0e0) goto S320;

8464

*qans = c*(w+rt2pin*t/rta);

8465

*ans = 0.5e0+(0.5e0-*qans);

8466

return;

8467

S320:

8468

*ans = c*(w-rt2pin*t/rta);

8469

*qans = 0.5e0+(0.5e0-*ans);

8470

return;

8471

S330:

8472

8473

// TEMME EXPANSION FOR L = 1

8474

8475

if(*a*e*e > 3.28e-3) goto S430;

8476

c = 0.5e0+(0.5e0-y);

8477

w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c;

8478

u = 1.0e0/ *a;

8479

z = sqrt(z+z);

8480

if(l < 1.0e0) z = -z;

8481

T5 = iop-2;

8482

if(T5 < 0) goto S340;

8483

else if(T5 == 0) goto S350;

8484

else goto S360;

8485

S340:

8486

c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-

8487

third;

8488

c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;

8489

c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20;

8490

c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30;

8491

c4 = (d4[1]*z+d4[0])*z+d40;

8492

c5 = (d5[1]*z+d5[0])*z+d50;

8493

c6 = d6[0]*z+d60;

8494

t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;

8495

goto S310;

8496

S350:

8497

c0 = (d0[1]*z+d0[0])*z-third;

8498

c1 = d1[0]*z+d10;

8499

t = (d20*u+c1)*u+c0;

8500

goto S310;

8501

S360:

8502

t = d0[0]*z-third;

8503

goto S310;

8504

S370:

8505

8506

// SPECIAL CASES

8507

8508

*ans = 0.0e0;

8509

*qans = 1.0e0;

8510

return;

8511

S380:

8512

*ans = 1.0e0;

8513

*qans = 0.0e0;

8514

return;

8515

S390:

8516

if(*x >= 0.25e0) goto S400;

8517

T6 = sqrt(*x);

8518

*ans = error_f ( &T6 );

8519

*qans = 0.5e0+(0.5e0-*ans);

8520

return;

8521

S400:

8522

T7 = sqrt(*x);

8523

*qans = error_fc ( &K2, &T7 );

8524

*ans = 0.5e0+(0.5e0-*qans);

8525

return;

8526

S410:

8527

if(fabs(s) <= 2.0e0*e) goto S430;

8528

S420:

8529

if(*x <= *a) goto S370;

8530

goto S380;

8531

S430:

8532

8533

// ERROR RETURN

8534

8535

*ans = 2.0e0;

8536

return;

8537

}

8538

//****************************************************************************80

8539

8540

void gamma_inc_inv ( double *a, double *x, double *x0, double *p, double *q,

8541

int *ierr )

8542

8543

//****************************************************************************80

8544

8545

// Purpose:

8546

8547

// GAMMA_INC_INV computes the inverse incomplete gamma ratio function.

8548

8549

// Discussion:

8550

8551

// The routine is given positive A, and nonnegative P and Q where P + Q = 1.

8552

// The value X is computed with the property that P(A,X) = P and Q(A,X) = Q.

8553

// Schroder iteration is employed. The routine attempts to compute X

8554

// to 10 significant digits if this is possible for the particular computer

8555

// arithmetic being used.

8556

8557

// Author:

8558

8559

// Alfred H Morris, Jr,

8560

// Naval Surface Weapons Center,

8561

// Dahlgren, Virginia.

8562

8563

// Parameters:

8564

8565

// Input, double *A, the parameter in the incomplete gamma

8566

// ratio. A must be positive.

8567

8568

// Output, double *X, the computed point for which the

8569

// incomplete gamma functions have the values P and Q.

8570

8571

// Input, double *X0, an optional initial approximation

8572

// for the solution X. If the user does not want to supply an

8573

// initial approximation, then X0 should be set to 0, or a negative

8574

// value.

8575

8576

// Input, double *P, *Q, the values of the incomplete gamma

8577

// functions, for which the corresponding argument is desired.

8578

8579

// Output, int *IERR, error flag.

8580

// 0, the solution was obtained. Iteration was not used.

8581

// 0 < K, The solution was obtained. IERR iterations were performed.

8582

// -2, A <= 0

8583

// -3, No solution was obtained. The ratio Q/A is too large.

8584

// -4, P + Q /= 1

8585

// -6, 20 iterations were performed. The most recent value obtained

8586

// for X is given. This cannot occur if X0 <= 0.

8587

// -7, Iteration failed. No value is given for X.

8588

// This may occur when X is approximately 0.

8589

// -8, A value for X has been obtained, but the routine is not certain

8590

// of its accuracy. Iteration cannot be performed in this

8591

// case. If X0 <= 0, this can occur only when P or Q is

8592

// approximately 0. If X0 is positive then this can occur when A is

8593

// exceedingly close to X and A is extremely large (say A .GE. 1.E20).

8594

8595

{

8596

static double a0 = 3.31125922108741e0;

8597

static double a1 = 11.6616720288968e0;

8598

static double a2 = 4.28342155967104e0;

8599

static double a3 = .213623493715853e0;

8600

static double b1 = 6.61053765625462e0;

8601

static double b2 = 6.40691597760039e0;

8602

static double b3 = 1.27364489782223e0;

8603

static double b4 = .036117081018842e0;

8604

static double c = .577215664901533e0;

8605

static double ln10 = 2.302585e0;

8606

static double tol = 1.e-5;

8607

static double amin[2] = {

8608

500.0e0,100.0e0

8609

};

8610

static double bmin[2] = {

8611

1.e-28,1.e-13

8612

};

8613

static double dmin[2] = {

8614

1.e-06,1.e-04

8615

};

8616

static double emin[2] = {

8617

2.e-03,6.e-03

8618

};

8619

static double eps0[2] = {

8620

1.e-10,1.e-08

8621

};

8622

static int K1 = 1;

8623

static int K2 = 2;

8624

static int K3 = 3;

8625

static int K8 = 0;

8626

static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn,

8627

r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z;

8628

static int iop;

8629

static double T4,T5,T6,T7,T9;

8630

8631

8632

// E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS.

8633

// E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0.

8634

// XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE

8635

// LARGEST POSITIVE NUMBER.

8636

8637

e = dpmpar(&K1);

8638

xmin = dpmpar(&K2);

8639

xmax = dpmpar(&K3);

8640

*x = 0.0e0;

8641

if(*a <= 0.0e0) goto S300;

8642

t = *p+*q-1.e0;

8643

if(fabs(t) > e) goto S320;

8644

*ierr = 0;

8645

if(*p == 0.0e0) return;

8646

if(*q == 0.0e0) goto S270;

8647

if(*a == 1.0e0) goto S280;

8648

e2 = 2.0e0*e;

8649

amax = 0.4e-10/(e*e);

8650

iop = 1;

8651

if(e > 1.e-10) iop = 2;

8652

eps = eps0[iop-1];

8653

xn = *x0;

8654

if(*x0 > 0.0e0) goto S160;

8655

8656

// SELECTION OF THE INITIAL APPROXIMATION XN OF X

8657

// WHEN A .LT. 1

8658

8659

if(*a > 1.0e0) goto S80;

8660

T4 = *a+1.0e0;

8661

g = gamma_x(&T4);

8662

qg = *q*g;

8663

if(qg == 0.0e0) goto S360;

8664

b = qg/ *a;

8665

if(qg > 0.6e0**a) goto S40;

8666

if(*a >= 0.30e0 || b < 0.35e0) goto S10;

8667

t = exp(-(b+c));

8668

u = t*exp(t);

8669

xn = t*exp(u);

8670

goto S160;

8671

S10:

8672

if(b >= 0.45e0) goto S40;

8673

if(b == 0.0e0) goto S360;

8674

y = -log(b);

8675

s = 0.5e0+(0.5e0-*a);

8676

z = log(y);

8677

t = y-s*z;

8678

if(b < 0.15e0) goto S20;

8679

xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0));

8680

goto S220;

8681

S20:

8682

if(b <= 0.01e0) goto S30;

8683

u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0);

8684

xn = y-s*log(t)-log(u);

8685

goto S220;

8686

S30:

8687

c1 = -(s*z);

8688

c2 = -(s*(1.0e0+c1));

8689

c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a));

8690

c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+(

8691

(11.0e0**a-46.0)**a+47.0e0)/6.0e0));

8692

c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)*

8693

*a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+((

8694

(25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0));

8695

xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y;

8696

if(*a > 1.0e0) goto S220;

8697

if(b > bmin[iop-1]) goto S220;

8698

*x = xn;

8699

return;

8700

S40:

8701

if(b**q > 1.e-8) goto S50;

8702

xn = exp(-(*q/ *a+c));

8703

goto S70;

8704

S50:

8705

if(*p <= 0.9e0) goto S60;

8706

T5 = -*q;

8707

xn = exp((alnrel(&T5)+ gamma_ln1 ( a ) ) / *a );

8708

goto S70;

8709

S60:

8710

xn = exp(log(*p*g)/ *a);

8711

S70:

8712

if(xn == 0.0e0) goto S310;

8713

t = 0.5e0+(0.5e0-xn/(*a+1.0e0));

8714

xn /= t;

8715

goto S160;

8716

S80:

8717

8718

// SELECTION OF THE INITIAL APPROXIMATION XN OF X

8719

// WHEN A .GT. 1

8720

8721

if(*q <= 0.5e0) goto S90;

8722

w = log(*p);

8723

goto S100;

8724

S90:

8725

w = log(*q);

8726

S100:

8727

t = sqrt(-(2.0e0*w));

8728

s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0);

8729

if(*q > 0.5e0) s = -s;

8730

rta = sqrt(*a);

8731

s2 = s*s;

8732

xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)*

8733

s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a*

8734

rta);

8735

xn = fifdmax1(xn,0.0e0);

8736

if(*a < amin[iop-1]) goto S110;

8737

*x = xn;

8738

d = 0.5e0+(0.5e0-*x/ *a);

8739

if(fabs(d) <= dmin[iop-1]) return;

8740

S110:

8741

if(*p <= 0.5e0) goto S130;

8742

if(xn < 3.0e0**a) goto S220;

8743

y = -(w+ gamma_log ( a ) );

8744

d = fifdmax1(2.0e0,*a*(*a-1.0e0));

8745

if(y < ln10*d) goto S120;

8746

s = 1.0e0-*a;

8747

z = log(y);

8748

goto S30;

8749

S120:

8750

t = *a-1.0e0;

8751

T6 = -(t/(xn+1.0e0));

8752

xn = y+t*log(xn)-alnrel(&T6);

8753

T7 = -(t/(xn+1.0e0));

8754

xn = y+t*log(xn)-alnrel(&T7);

8755

goto S220;

8756

S130:

8757

ap1 = *a+1.0e0;

8758

if(xn > 0.70e0*ap1) goto S170;

8759

w += gamma_log ( &ap1 );

8760

if(xn > 0.15e0*ap1) goto S140;

8761

ap2 = *a+2.0e0;

8762

ap3 = *a+3.0e0;

8763

*x = exp((w+*x)/ *a);

8764

*x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);

8765

*x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);

8766

*x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a);

8767

xn = *x;

8768

if(xn > 1.e-2*ap1) goto S140;

8769

if(xn <= emin[iop-1]*ap1) return;

8770

goto S170;

8771

S140:

8772

apn = ap1;

8773

t = xn/apn;

8774

sum = 1.0e0+t;

8775

S150:

8776

apn += 1.0e0;

8777

t *= (xn/apn);

8778

sum += t;

8779

if(t > 1.e-4) goto S150;

8780

t = w-log(sum);

8781

xn = exp((xn+t)/ *a);

8782

xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn));

8783

goto S170;

8784

S160:

8785

8786

// SCHRODER ITERATION USING P

8787

8788

if(*p > 0.5e0) goto S220;

8789

S170:

8790

if(*p <= 1.e10*xmin) goto S350;

8791

am1 = *a-0.5e0-0.5e0;

8792

S180:

8793

if(*a <= amax) goto S190;

8794

d = 0.5e0+(0.5e0-xn/ *a);

8795

if(fabs(d) <= e2) goto S350;

8796

S190:

8797

if(*ierr >= 20) goto S330;

8798

*ierr += 1;

8799

gamma_inc ( a, &xn, &pn, &qn, &K8 );

8800

if(pn == 0.0e0 || qn == 0.0e0) goto S350;

8801

r = rcomp(a,&xn);

8802

if(r == 0.0e0) goto S350;

8803

t = (pn-*p)/r;

8804

w = 0.5e0*(am1-xn);

8805

if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200;

8806

*x = xn*(1.0e0-t);

8807

if(*x <= 0.0e0) goto S340;

8808

d = fabs(t);

8809

goto S210;

8810

S200:

8811

h = t*(1.0e0+w*t);

8812

*x = xn*(1.0e0-h);

8813

if(*x <= 0.0e0) goto S340;

8814

if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;

8815

d = fabs(h);

8816

S210:

8817

xn = *x;

8818

if(d > tol) goto S180;

8819

if(d <= eps) return;

8820

if(fabs(*p-pn) <= tol**p) return;

8821

goto S180;

8822

S220:

8823

8824

// SCHRODER ITERATION USING Q

8825

8826

if(*q <= 1.e10*xmin) goto S350;

8827

am1 = *a-0.5e0-0.5e0;

8828

S230:

8829

if(*a <= amax) goto S240;

8830

d = 0.5e0+(0.5e0-xn/ *a);

8831

if(fabs(d) <= e2) goto S350;

8832

S240:

8833

if(*ierr >= 20) goto S330;

8834

*ierr += 1;

8835

gamma_inc ( a, &xn, &pn, &qn, &K8 );

8836

if(pn == 0.0e0 || qn == 0.0e0) goto S350;

8837

r = rcomp(a,&xn);

8838

if(r == 0.0e0) goto S350;

8839

t = (*q-qn)/r;

8840

w = 0.5e0*(am1-xn);

8841

if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250;

8842

*x = xn*(1.0e0-t);

8843

if(*x <= 0.0e0) goto S340;

8844

d = fabs(t);

8845

goto S260;

8846

S250:

8847

h = t*(1.0e0+w*t);

8848

*x = xn*(1.0e0-h);

8849

if(*x <= 0.0e0) goto S340;

8850

if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;

8851

d = fabs(h);

8852

S260:

8853

xn = *x;

8854

if(d > tol) goto S230;

8855

if(d <= eps) return;

8856

if(fabs(*q-qn) <= tol**q) return;

8857

goto S230;

8858

S270:

8859

8860

// SPECIAL CASES

8861

8862

*x = xmax;

8863

return;

8864

S280:

8865

if(*q < 0.9e0) goto S290;

8866

T9 = -*p;

8867

*x = -alnrel(&T9);

8868

return;

8869

S290:

8870

*x = -log(*q);

8871

return;

8872

S300:

8873

8874

// ERROR RETURN

8875

8876

*ierr = -2;

8877

return;

8878

S310:

8879

*ierr = -3;

8880

return;

8881

S320:

8882

*ierr = -4;

8883

return;

8884

S330:

8885

*ierr = -6;

8886

return;

8887

S340:

8888

*ierr = -7;

8889

return;

8890

S350:

8891

*x = xn;

8892

*ierr = -8;

8893

return;

8894

S360:

8895

*x = xmax;

8896

*ierr = -8;

8897

return;

8898

}

8899

//****************************************************************************80

8900

8901

void gamma_inc_values ( int *n_data, double *a, double *x, double *fx )

8902

8903

//****************************************************************************80

8904

8905

// Purpose:

8906

8907

// GAMMA_INC_VALUES returns some values of the incomplete Gamma function.

8908

8909

// Discussion:

8910

8911

// The (normalized) incomplete Gamma function P(A,X) is defined as:

8912

8913

// PN(A,X) = 1/GAMMA(A) * Integral ( 0 <= T <= X ) T**(A-1) * exp(-T) dT.

8914

8915

// With this definition, for all A and X,

8916

8917

// 0 <= PN(A,X) <= 1

8918

8919

// and

8920

8921

// PN(A,INFINITY) = 1.0

8922

8923

// Mathematica can compute this value as

8924

8925

// 1 - GammaRegularized[A,X]

8926

8927

// Modified:

8928

8929

// 31 May 2004

8930

8931

// Author:

8932

8933

// John Burkardt

8934

8935

// Reference:

8936

8937

// Milton Abramowitz and Irene Stegun,

8938

// Handbook of Mathematical Functions,

8939

// US Department of Commerce, 1964.

8940

8941

// Parameters:

8942

8943

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

8944

// first call. On each call, the routine increments N_DATA by 1, and

8945

// returns the corresponding data; when there is no more data, the

8946

// output value of N_DATA will be 0 again.

8947

8948

// Output, double *A, the parameter of the function.

8949

8950

// Output, double *X, the argument of the function.

8951

8952

// Output, double *FX, the value of the function.

8953

8954

{

8955

# define N_MAX 20

8956

8957

double a_vec[N_MAX] = {

8958

0.1E+00, 0.1E+00, 0.1E+00, 0.5E+00,

8959

0.5E+00, 0.5E+00, 1.0E+00, 1.0E+00,

8960

1.0E+00, 1.1E+00, 1.1E+00, 1.1E+00,

8961

2.0E+00, 2.0E+00, 2.0E+00, 6.0E+00,

8962

6.0E+00, 11.0E+00, 26.0E+00, 41.0E+00 };

8963

double fx_vec[N_MAX] = {

8964

0.7420263E+00, 0.9119753E+00, 0.9898955E+00, 0.2931279E+00,

8965

0.7656418E+00, 0.9921661E+00, 0.0951626E+00, 0.6321206E+00,

8966

0.9932621E+00, 0.0757471E+00, 0.6076457E+00, 0.9933425E+00,

8967

0.0091054E+00, 0.4130643E+00, 0.9931450E+00, 0.0387318E+00,

8968

0.9825937E+00, 0.9404267E+00, 0.4863866E+00, 0.7359709E+00 };

8969

double x_vec[N_MAX] = {

8970

3.1622777E-02, 3.1622777E-01, 1.5811388E+00, 7.0710678E-02,

8971

7.0710678E-01, 3.5355339E+00, 0.1000000E+00, 1.0000000E+00,

8972

5.0000000E+00, 1.0488088E-01, 1.0488088E+00, 5.2440442E+00,

8973

1.4142136E-01, 1.4142136E+00, 7.0710678E+00, 2.4494897E+00,

8974

1.2247449E+01, 1.6583124E+01, 2.5495098E+01, 4.4821870E+01 };

8975

8976

if ( *n_data < 0 )

8977

{

8978

*n_data = 0;

8979

}

8980

8981

*n_data = *n_data + 1;

8982

8983

if ( N_MAX < *n_data )

8984

{

8985

*n_data = 0;

8986

*a = 0.0E+00;

8987

*x = 0.0E+00;

8988

*fx = 0.0E+00;

8989

}

8990

else

8991

{

8992

*a = a_vec[*n_data-1];

8993

*x = x_vec[*n_data-1];

8994

*fx = fx_vec[*n_data-1];

8995

}

8996

return;

8997

# undef N_MAX

8998

}

8999

//****************************************************************************80

9000

9001

double gamma_ln1 ( double *a )

9002

9003

//****************************************************************************80

9004

9005

// Purpose:

9006

9007

// GAMMA_LN1 evaluates ln ( Gamma ( 1 + A ) ), for -0.2 <= A <= 1.25.

9008

9009

// Parameters:

9010

9011

// Input, double *A, defines the argument of the function.

9012

9013

// Output, double GAMMA_LN1, the value of ln ( Gamma ( 1 + A ) ).

9014

9015

{

9016

static double p0 = .577215664901533e+00;

9017

static double p1 = .844203922187225e+00;

9018

static double p2 = -.168860593646662e+00;

9019

static double p3 = -.780427615533591e+00;

9020

static double p4 = -.402055799310489e+00;

9021

static double p5 = -.673562214325671e-01;

9022

static double p6 = -.271935708322958e-02;

9023

static double q1 = .288743195473681e+01;

9024

static double q2 = .312755088914843e+01;

9025

static double q3 = .156875193295039e+01;

9026

static double q4 = .361951990101499e+00;

9027

static double q5 = .325038868253937e-01;

9028

static double q6 = .667465618796164e-03;

9029

static double r0 = .422784335098467e+00;

9030

static double r1 = .848044614534529e+00;

9031

static double r2 = .565221050691933e+00;

9032

static double r3 = .156513060486551e+00;

9033

static double r4 = .170502484022650e-01;

9034

static double r5 = .497958207639485e-03;

9035

static double s1 = .124313399877507e+01;

9036

static double s2 = .548042109832463e+00;

9037

static double s3 = .101552187439830e+00;

9038

static double s4 = .713309612391000e-02;

9039

static double s5 = .116165475989616e-03;

9040

static double gamln1,w,x;

9041

9042

if(*a >= 0.6e0) goto S10;

9043

w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+

9044

q4)**a+q3)**a+q2)**a+q1)**a+1.0e0);

9045

gamln1 = -(*a*w);

9046

return gamln1;

9047

S10:

9048

x = *a-0.5e0-0.5e0;

9049

w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x

9050

+1.0e0);

9051

gamln1 = x*w;

9052

return gamln1;

9053

}

9054

//****************************************************************************80

9055

9056

double gamma_log ( double *a )

9057

9058

//****************************************************************************80

9059

9060

// Purpose:

9061

9062

// GAMMA_LOG evaluates ln ( Gamma ( A ) ) for positive A.

9063

9064

// Author:

9065

9066

// Alfred H Morris, Jr,

9067

// Naval Surface Weapons Center,

9068

// Dahlgren, Virginia.

9069

9070

// Reference:

9071

9072

// Armido DiDinato and Alfred Morris,

9073

// Algorithm 708:

9074

// Significant Digit Computation of the Incomplete Beta Function Ratios,

9075

// ACM Transactions on Mathematical Software,

9076

// Volume 18, 1993, pages 360-373.

9077

9078

// Parameters:

9079

9080

// Input, double *A, the argument of the function.

9081

// A should be positive.

9082

9083

// Output, double GAMMA_LOG, the value of ln ( Gamma ( A ) ).

9084

9085

{

9086

static double c0 = .833333333333333e-01;

9087

static double c1 = -.277777777760991e-02;

9088

static double c2 = .793650666825390e-03;

9089

static double c3 = -.595202931351870e-03;

9090

static double c4 = .837308034031215e-03;

9091

static double c5 = -.165322962780713e-02;

9092

static double d = .418938533204673e0;

9093

static double gamln,t,w;

9094

static int i,n;

9095

static double T1;

9096

9097

if(*a > 0.8e0) goto S10;

9098

gamln = gamma_ln1 ( a ) - log ( *a );

9099

return gamln;

9100

S10:

9101

if(*a > 2.25e0) goto S20;

9102

t = *a-0.5e0-0.5e0;

9103

gamln = gamma_ln1 ( &t );

9104

return gamln;

9105

S20:

9106

if(*a >= 10.0e0) goto S40;

9107

n = ( int ) ( *a - 1.25e0 );

9108

t = *a;

9109

w = 1.0e0;

9110

for ( i = 1; i <= n; i++ )

9111

{

9112

t -= 1.0e0;

9113

w = t*w;

9114

}

9115

T1 = t-1.0e0;

9116

gamln = gamma_ln1 ( &T1 ) + log ( w );

9117

return gamln;

9118

S40:

9119

t = pow(1.0e0/ *a,2.0);

9120

w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a;

9121

gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0);

9122

return gamln;

9123

}

9124

//****************************************************************************80

9125

9126

void gamma_rat1 ( double *a, double *x, double *r, double *p, double *q,

9127

double *eps )

9128

9129

//****************************************************************************80

9130

9131

// Purpose:

9132

9133

// GAMMA_RAT1 evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).

9134

9135

// Parameters:

9136

9137

// Input, double *A, *X, the parameters of the functions.

9138

// It is assumed that A <= 1.

9139

9140

// Input, double *R, the value exp(-X) * X**A / Gamma(A).

9141

9142

// Output, double *P, *Q, the values of P(A,X) and Q(A,X).

9143

9144

// Input, double *EPS, the tolerance.

9145

9146

{

9147

static int K2 = 0;

9148

static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3;

9149

9150

if(*a**x == 0.0e0) goto S120;

9151

if(*a == 0.5e0) goto S100;

9152

if(*x < 1.1e0) goto S10;

9153

goto S60;

9154

S10:

9155

9156

// TAYLOR SERIES FOR P(A,X)/X**A

9157

9158

an = 3.0e0;

9159

c = *x;

9160

sum = *x/(*a+3.0e0);

9161

tol = 0.1e0**eps/(*a+1.0e0);

9162

S20:

9163

an += 1.0e0;

9164

c = -(c*(*x/an));

9165

t = c/(*a+an);

9166

sum += t;

9167

if(fabs(t) > tol) goto S20;

9168

j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));

9169

z = *a*log(*x);

9170

h = gam1(a);

9171

g = 1.0e0+h;

9172

if(*x < 0.25e0) goto S30;

9173

if(*a < *x/2.59e0) goto S50;

9174

goto S40;

9175

S30:

9176

if(z > -.13394e0) goto S50;

9177

S40:

9178

w = exp(z);

9179

*p = w*g*(0.5e0+(0.5e0-j));

9180

*q = 0.5e0+(0.5e0-*p);

9181

return;

9182

S50:

9183

l = rexp(&z);

9184

w = 0.5e0+(0.5e0+l);

9185

*q = (w*j-l)*g-h;

9186

if(*q < 0.0e0) goto S90;

9187

*p = 0.5e0+(0.5e0-*q);

9188

return;

9189

S60:

9190

9191

// CONTINUED FRACTION EXPANSION

9192

9193

a2nm1 = a2n = 1.0e0;

9194

b2nm1 = *x;

9195

b2n = *x+(1.0e0-*a);

9196

c = 1.0e0;

9197

S70:

9198

a2nm1 = *x*a2n+c*a2nm1;

9199

b2nm1 = *x*b2n+c*b2nm1;

9200

am0 = a2nm1/b2nm1;

9201

c += 1.0e0;

9202

cma = c-*a;

9203

a2n = a2nm1+cma*a2n;

9204

b2n = b2nm1+cma*b2n;

9205

an0 = a2n/b2n;

9206

if(fabs(an0-am0) >= *eps*an0) goto S70;

9207

*q = *r*an0;

9208

*p = 0.5e0+(0.5e0-*q);

9209

return;

9210

S80:

9211

9212

// SPECIAL CASES

9213

9214

*p = 0.0e0;

9215

*q = 1.0e0;

9216

return;

9217

S90:

9218

*p = 1.0e0;

9219

*q = 0.0e0;

9220

return;

9221

S100:

9222

if(*x >= 0.25e0) goto S110;

9223

T1 = sqrt(*x);

9224

*p = error_f ( &T1 );

9225

*q = 0.5e0+(0.5e0-*p);

9226

return;

9227

S110:

9228

T3 = sqrt(*x);

9229

*q = error_fc ( &K2, &T3 );

9230

*p = 0.5e0+(0.5e0-*q);

9231

return;

9232

S120:

9233

if(*x <= *a) goto S80;

9234

goto S90;

9235

}

9236

//****************************************************************************80

9237

9238

void gamma_values ( int *n_data, double *x, double *fx )

9239

9240

//****************************************************************************80

9241

9242

// Purpose:

9243

9244

// GAMMA_VALUES returns some values of the Gamma function.

9245

9246

// Definition:

9247

9248

// GAMMA(Z) = Integral ( 0 <= T < Infinity) T**(Z-1) EXP(-T) dT

9249

9250

// Recursion:

9251

9252

// GAMMA(X+1) = X*GAMMA(X)

9253

9254

// Restrictions:

9255

9256

// 0 < X ( a software restriction).

9257

9258

// Special values:

9259

9260

// GAMMA(0.5) = sqrt(PI)

9261

9262

// For N a positive integer, GAMMA(N+1) = N!, the standard factorial.

9263

9264

// Modified:

9265

9266

// 31 May 2004

9267

9268

// Author:

9269

9270

// John Burkardt

9271

9272

// Reference:

9273

9274

// Milton Abramowitz and Irene Stegun,

9275

// Handbook of Mathematical Functions,

9276

// US Department of Commerce, 1964.

9277

9278

// Parameters:

9279

9280

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

9281

// first call. On each call, the routine increments N_DATA by 1, and

9282

// returns the corresponding data; when there is no more data, the

9283

// output value of N_DATA will be 0 again.

9284

9285

// Output, double *X, the argument of the function.

9286

9287

// Output, double *FX, the value of the function.

9288

9289

{

9290

# define N_MAX 18

9291

9292

double fx_vec[N_MAX] = {

9293

4.590845E+00, 2.218160E+00, 1.489192E+00, 1.164230E+00,

9294

1.0000000000E+00, 0.9513507699E+00, 0.9181687424E+00, 0.8974706963E+00,

9295

0.8872638175E+00, 0.8862269255E+00, 0.8935153493E+00, 0.9086387329E+00,

9296

0.9313837710E+00, 0.9617658319E+00, 1.0000000000E+00, 3.6288000E+05,

9297

1.2164510E+17, 8.8417620E+30 };

9298

double x_vec[N_MAX] = {

9299

0.2E+00, 0.4E+00, 0.6E+00, 0.8E+00,

9300

1.0E+00, 1.1E+00, 1.2E+00, 1.3E+00,

9301

1.4E+00, 1.5E+00, 1.6E+00, 1.7E+00,

9302

1.8E+00, 1.9E+00, 2.0E+00, 10.0E+00,

9303

20.0E+00, 30.0E+00 };

9304

9305

if ( *n_data < 0 )

9306

{

9307

*n_data = 0;

9308

}

9309

9310

*n_data = *n_data + 1;

9311

9312

if ( N_MAX < *n_data )

9313

{

9314

*n_data = 0;

9315

*x = 0.0E+00;

9316

*fx = 0.0E+00;

9317

}

9318

else

9319

{

9320

*x = x_vec[*n_data-1];

9321

*fx = fx_vec[*n_data-1];

9322

}

9323

return;

9324

# undef N_MAX

9325

}

9326

//****************************************************************************80

9327

9328

double gamma_x ( double *a )

9329

9330

//****************************************************************************80

9331

9332

// Purpose:

9333

9334

// GAMMA_X evaluates the gamma function.

9335

9336

// Discussion:

9337

9338

// This routine was renamed from "GAMMA" to avoid a conflict with the

9339

// C/C++ math library routine.

9340

9341

// Author:

9342

9343

// Alfred H Morris, Jr,

9344

// Naval Surface Weapons Center,

9345

// Dahlgren, Virginia.

9346

9347

// Parameters:

9348

9349

// Input, double *A, the argument of the Gamma function.

9350

9351

// Output, double GAMMA_X, the value of the Gamma function.

9352

9353

{

9354

static double d = .41893853320467274178e0;

9355

static double pi = 3.1415926535898e0;

9356

static double r1 = .820756370353826e-03;

9357

static double r2 = -.595156336428591e-03;

9358

static double r3 = .793650663183693e-03;

9359

static double r4 = -.277777777770481e-02;

9360

static double r5 = .833333333333333e-01;

9361

static double p[7] = {

9362

.539637273585445e-03,.261939260042690e-02,.204493667594920e-01,

9363

.730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0

9364

};

9365

static double q[7] = {

9366

-.832979206704073e-03,.470059485860584e-02,.225211131035340e-01,

9367

-.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0

9368

};

9369

static int K2 = 3;

9370

static int K3 = 0;

9371

static double Xgamm,bot,g,lnx,s,t,top,w,x,z;

9372

static int i,j,m,n,T1;

9373

9374

Xgamm = 0.0e0;

9375

x = *a;

9376

if(fabs(*a) >= 15.0e0) goto S110;

9377

9378

// EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15

9379

9380

t = 1.0e0;

9381

m = fifidint(*a)-1;

9382

9383

// LET T BE THE PRODUCT OF A-J WHEN A .GE. 2

9384

9385

T1 = m;

9386

if(T1 < 0) goto S40;

9387

else if(T1 == 0) goto S30;

9388

else goto S10;

9389

S10:

9390

for ( j = 1; j <= m; j++ )

9391

{

9392

x -= 1.0e0;

9393

t = x*t;

9394

}

9395

S30:

9396

x -= 1.0e0;

9397

goto S80;

9398

S40:

9399

9400

// LET T BE THE PRODUCT OF A+J WHEN A .LT. 1

9401

9402

t = *a;

9403

if(*a > 0.0e0) goto S70;

9404

m = -m-1;

9405

if(m == 0) goto S60;

9406

for ( j = 1; j <= m; j++ )

9407

{

9408

x += 1.0e0;

9409

t = x*t;

9410

}

9411

S60:

9412

x += (0.5e0+0.5e0);

9413

t = x*t;

9414

if(t == 0.0e0) return Xgamm;

9415

S70:

9416

9417

// THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS

9418

// CODE MAY BE OMITTED IF DESIRED.

9419

9420

if(fabs(t) >= 1.e-30) goto S80;

9421

if(fabs(t)*dpmpar(&K2) <= 1.0001e0) return Xgamm;

9422

Xgamm = 1.0e0/t;

9423

return Xgamm;

9424

S80:

9425

9426

// COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1

9427

9428

top = p[0];

9429

bot = q[0];

9430

for ( i = 1; i < 7; i++ )

9431

{

9432

top = p[i]+x*top;

9433

bot = q[i]+x*bot;

9434

}

9435

Xgamm = top/bot;

9436

9437

// TERMINATION

9438

9439

if(*a < 1.0e0) goto S100;

9440

Xgamm *= t;

9441

return Xgamm;

9442

S100:

9443

Xgamm /= t;

9444

return Xgamm;

9445

S110:

9446

9447

// EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15

9448

9449

if(fabs(*a) >= 1.e3) return Xgamm;

9450

if(*a > 0.0e0) goto S120;

9451

x = -*a;

9452

n = ( int ) x;

9453

t = x-(double)n;

9454

if(t > 0.9e0) t = 1.0e0-t;

9455

s = sin(pi*t)/pi;

9456

if(fifmod(n,2) == 0) s = -s;

9457

if(s == 0.0e0) return Xgamm;

9458

S120:

9459

9460

// COMPUTE THE MODIFIED ASYMPTOTIC SUM

9461

9462

t = 1.0e0/(x*x);

9463

g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x;

9464

9465

// ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X)

9466

// BUT LESS ACCURACY WILL NORMALLY BE OBTAINED.

9467

9468

lnx = log(x);

9469

9470

// FINAL ASSEMBLY

9471

9472

z = x;

9473

g = d+g+(z-0.5e0)*(lnx-1.e0);

9474

w = g;

9475

t = g-w;

9476

if(w > 0.99999e0*exparg(&K3)) return Xgamm;

9477

Xgamm = exp(w)*(1.0e0+t);

9478

if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x;

9479

return Xgamm;

9480

}

9481

//****************************************************************************80

9482

9483

double gsumln ( double *a, double *b )

9484

9485

//****************************************************************************80

9486

9487

// Purpose:

9488

9489

// GSUMLN evaluates the function ln(Gamma(A + B)).

9490

9491

// Discussion:

9492

9493

// GSUMLN is used for 1 <= A <= 2 and 1 <= B <= 2

9494

9495

// Parameters:

9496

9497

// Input, double *A, *B, values whose sum is the argument of

9498

// the Gamma function.

9499

9500

// Output, double GSUMLN, the value of ln(Gamma(A+B)).

9501

9502

{

9503

static double gsumln,x,T1,T2;

9504

9505

x = *a+*b-2.e0;

9506

if(x > 0.25e0) goto S10;

9507

T1 = 1.0e0+x;

9508

gsumln = gamma_ln1 ( &T1 );

9509

return gsumln;

9510

S10:

9511

if(x > 1.25e0) goto S20;

9512

gsumln = gamma_ln1 ( &x ) + alnrel ( &x );

9513

return gsumln;

9514

S20:

9515

T2 = x-1.0e0;

9516

gsumln = gamma_ln1 ( &T2 ) + log ( x * ( 1.0e0 + x ) );

9517

return gsumln;

9518

}

9519

//****************************************************************************80

9520

9521

int ipmpar ( int *i )

9522

9523

//****************************************************************************80

9524

9525

// Purpose:

9526

9527

// IPMPAR returns integer machine constants.

9528

9529

// Discussion:

9530

9531

// Input arguments 1 through 3 are queries about integer arithmetic.

9532

// We assume integers are represented in the N-digit, base-A form

9533

9534

// sign * ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) )

9535

9536

// where 0 <= X(0:N-1) < A.

9537

9538

// Then:

9539

9540

// IPMPAR(1) = A, the base of integer arithmetic;

9541

// IPMPAR(2) = N, the number of base A digits;

9542

// IPMPAR(3) = A**N - 1, the largest magnitude.

9543

9544

// It is assumed that the single and double precision floating

9545

// point arithmetics have the same base, say B, and that the

9546

// nonzero numbers are represented in the form

9547

9548

// sign * (B**E) * (X(1)/B + ... + X(M)/B**M)

9549

9550

// where X(1:M) is one of { 0, 1,..., B-1 }, and 1 <= X(1) and

9551

// EMIN <= E <= EMAX.

9552

9553

// Input argument 4 is a query about the base of real arithmetic:

9554

9555

// IPMPAR(4) = B, the base of single and double precision arithmetic.

9556

9557

// Input arguments 5 through 7 are queries about single precision

9558

// floating point arithmetic:

9559

9560

// IPMPAR(5) = M, the number of base B digits for single precision.

9561

// IPMPAR(6) = EMIN, the smallest exponent E for single precision.

9562

// IPMPAR(7) = EMAX, the largest exponent E for single precision.

9563

9564

// Input arguments 8 through 10 are queries about double precision

9565

// floating point arithmetic:

9566

9567

// IPMPAR(8) = M, the number of base B digits for double precision.

9568

// IPMPAR(9) = EMIN, the smallest exponent E for double precision.

9569

// IPMPAR(10) = EMAX, the largest exponent E for double precision.

9570

9571

// Reference:

9572

9573

// Phyllis Fox, Andrew Hall, and Norman Schryer,

9574

// Algorithm 528,

9575

// Framework for a Portable FORTRAN Subroutine Library,

9576

// ACM Transactions on Mathematical Software,

9577

// Volume 4, 1978, pages 176-188.

9578

9579

// Parameters:

9580

9581

// Input, int *I, the index of the desired constant.

9582

9583

// Output, int IPMPAR, the value of the desired constant.

9584

9585

{

9586

static int imach[11];

9587

static int ipmpar;

9588

// MACHINE CONSTANTS FOR AMDAHL MACHINES.

9589

9590

// imach[1] = 2;

9591

// imach[2] = 31;

9592

// imach[3] = 2147483647;

9593

// imach[4] = 16;

9594

// imach[5] = 6;

9595

// imach[6] = -64;

9596

// imach[7] = 63;

9597

// imach[8] = 14;

9598

// imach[9] = -64;

9599

// imach[10] = 63;

9600

9601

// MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T

9602

// PC 7300, AND AT&T 6300.

9603

9604

// imach[1] = 2;

9605

// imach[2] = 31;

9606

// imach[3] = 2147483647;

9607

// imach[4] = 2;

9608

// imach[5] = 24;

9609

// imach[6] = -125;

9610

// imach[7] = 128;

9611

// imach[8] = 53;

9612

// imach[9] = -1021;

9613

// imach[10] = 1024;

9614

9615

// MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.

9616

9617

// imach[1] = 2;

9618

// imach[2] = 33;

9619

// imach[3] = 8589934591;

9620

// imach[4] = 2;

9621

// imach[5] = 24;

9622

// imach[6] = -256;

9623

// imach[7] = 255;

9624

// imach[8] = 60;

9625

// imach[9] = -256;

9626

// imach[10] = 255;

9627

9628

// MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.

9629

9630

// imach[1] = 2;

9631

// imach[2] = 39;

9632

// imach[3] = 549755813887;

9633

// imach[4] = 8;

9634

// imach[5] = 13;

9635

// imach[6] = -50;

9636

// imach[7] = 76;

9637

// imach[8] = 26;

9638

// imach[9] = -50;

9639

// imach[10] = 76;

9640

9641

// MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.

9642

9643

// imach[1] = 2;

9644

// imach[2] = 39;

9645

// imach[3] = 549755813887;

9646

// imach[4] = 8;

9647

// imach[5] = 13;

9648

// imach[6] = -50;

9649

// imach[7] = 76;

9650

// imach[8] = 26;

9651

// imach[9] = -32754;

9652

// imach[10] = 32780;

9653

9654

// MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES

9655

// 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT

9656

// ARITHMETIC (NOS OPERATING SYSTEM).

9657

9658

// imach[1] = 2;

9659

// imach[2] = 48;

9660

// imach[3] = 281474976710655;

9661

// imach[4] = 2;

9662

// imach[5] = 48;

9663

// imach[6] = -974;

9664

// imach[7] = 1070;

9665

// imach[8] = 95;

9666

// imach[9] = -926;

9667

// imach[10] = 1070;

9668

9669

// MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT

9670

// ARITHMETIC (NOS/VE OPERATING SYSTEM).

9671

9672

// imach[1] = 2;

9673

// imach[2] = 63;

9674

// imach[3] = 9223372036854775807;

9675

// imach[4] = 2;

9676

// imach[5] = 48;

9677

// imach[6] = -4096;

9678

// imach[7] = 4095;

9679

// imach[8] = 96;

9680

// imach[9] = -4096;

9681

// imach[10] = 4095;

9682

9683

// MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.

9684

9685

// imach[1] = 2;

9686

// imach[2] = 63;

9687

// imach[3] = 9223372036854775807;

9688

// imach[4] = 2;

9689

// imach[5] = 47;

9690

// imach[6] = -8189;

9691

// imach[7] = 8190;

9692

// imach[8] = 94;

9693

// imach[9] = -8099;

9694

// imach[10] = 8190;

9695

9696

// MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200.

9697

9698

// imach[1] = 2;

9699

// imach[2] = 15;

9700

// imach[3] = 32767;

9701

// imach[4] = 16;

9702

// imach[5] = 6;

9703

// imach[6] = -64;

9704

// imach[7] = 63;

9705

// imach[8] = 14;

9706

// imach[9] = -64;

9707

// imach[10] = 63;

9708

9709

// MACHINE CONSTANTS FOR THE HARRIS 220.

9710

9711

// imach[1] = 2;

9712

// imach[2] = 23;

9713

// imach[3] = 8388607;

9714

// imach[4] = 2;

9715

// imach[5] = 23;

9716

// imach[6] = -127;

9717

// imach[7] = 127;

9718

// imach[8] = 38;

9719

// imach[9] = -127;

9720

// imach[10] = 127;

9721

9722

// MACHINE CONSTANTS FOR THE HONEYWELL 600/6000

9723

// AND DPS 8/70 SERIES.

9724

9725

// imach[1] = 2;

9726

// imach[2] = 35;

9727

// imach[3] = 34359738367;

9728

// imach[4] = 2;

9729

// imach[5] = 27;

9730

// imach[6] = -127;

9731

// imach[7] = 127;

9732

// imach[8] = 63;

9733

// imach[9] = -127;

9734

// imach[10] = 127;

9735

9736

// MACHINE CONSTANTS FOR THE HP 2100

9737

// 3 WORD DOUBLE PRECISION OPTION WITH FTN4

9738

9739

// imach[1] = 2;

9740

// imach[2] = 15;

9741

// imach[3] = 32767;

9742

// imach[4] = 2;

9743

// imach[5] = 23;

9744

// imach[6] = -128;

9745

// imach[7] = 127;

9746

// imach[8] = 39;

9747

// imach[9] = -128;

9748

// imach[10] = 127;

9749

9750

// MACHINE CONSTANTS FOR THE HP 2100

9751

// 4 WORD DOUBLE PRECISION OPTION WITH FTN4

9752

9753

// imach[1] = 2;

9754

// imach[2] = 15;

9755

// imach[3] = 32767;

9756

// imach[4] = 2;

9757

// imach[5] = 23;

9758

// imach[6] = -128;

9759

// imach[7] = 127;

9760

// imach[8] = 55;

9761

// imach[9] = -128;

9762

// imach[10] = 127;

9763

9764

// MACHINE CONSTANTS FOR THE HP 9000.

9765

9766

// imach[1] = 2;

9767

// imach[2] = 31;

9768

// imach[3] = 2147483647;

9769

// imach[4] = 2;

9770

// imach[5] = 24;

9771

// imach[6] = -126;

9772

// imach[7] = 128;

9773

// imach[8] = 53;

9774

// imach[9] = -1021;

9775

// imach[10] = 1024;

9776

9777

// MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,

9778

// THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA

9779

// 5/7/9 AND THE SEL SYSTEMS 85/86.

9780

9781

// imach[1] = 2;

9782

// imach[2] = 31;

9783

// imach[3] = 2147483647;

9784

// imach[4] = 16;

9785

// imach[5] = 6;

9786

// imach[6] = -64;

9787

// imach[7] = 63;

9788

// imach[8] = 14;

9789

// imach[9] = -64;

9790

// imach[10] = 63;

9791

9792

// MACHINE CONSTANTS FOR THE IBM PC.

9793

9794

// imach[1] = 2;

9795

// imach[2] = 31;

9796

// imach[3] = 2147483647;

9797

// imach[4] = 2;

9798

// imach[5] = 24;

9799

// imach[6] = -125;

9800

// imach[7] = 128;

9801

// imach[8] = 53;

9802

// imach[9] = -1021;

9803

// imach[10] = 1024;

9804

9805

// MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT

9806

// MACFORTRAN II.

9807

9808

// imach[1] = 2;

9809

// imach[2] = 31;

9810

// imach[3] = 2147483647;

9811

// imach[4] = 2;

9812

// imach[5] = 24;

9813

// imach[6] = -125;

9814

// imach[7] = 128;

9815

// imach[8] = 53;

9816

// imach[9] = -1021;

9817

// imach[10] = 1024;

9818

9819

// MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN.

9820

9821

// imach[1] = 2;

9822

// imach[2] = 31;

9823

// imach[3] = 2147483647;

9824

// imach[4] = 2;

9825

// imach[5] = 24;

9826

// imach[6] = -127;

9827

// imach[7] = 127;

9828

// imach[8] = 56;

9829

// imach[9] = -127;

9830

// imach[10] = 127;

9831

9832

// MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).

9833

9834

// imach[1] = 2;

9835

// imach[2] = 35;

9836

// imach[3] = 34359738367;

9837

// imach[4] = 2;

9838

// imach[5] = 27;

9839

// imach[6] = -128;

9840

// imach[7] = 127;

9841

// imach[8] = 54;

9842

// imach[9] = -101;

9843

// imach[10] = 127;

9844

9845

// MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).

9846

9847

// imach[1] = 2;

9848

// imach[2] = 35;

9849

// imach[3] = 34359738367;

9850

// imach[4] = 2;

9851

// imach[5] = 27;

9852

// imach[6] = -128;

9853

// imach[7] = 127;

9854

// imach[8] = 62;

9855

// imach[9] = -128;

9856

// imach[10] = 127;

9857

9858

// MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING

9859

// 32-BIT INTEGER ARITHMETIC.

9860

9861

// imach[1] = 2;

9862

// imach[2] = 31;

9863

// imach[3] = 2147483647;

9864

// imach[4] = 2;

9865

// imach[5] = 24;

9866

// imach[6] = -127;

9867

// imach[7] = 127;

9868

// imach[8] = 56;

9869

// imach[9] = -127;

9870

// imach[10] = 127;

9871

9872

// MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000.

9873

9874

// imach[1] = 2;

9875

// imach[2] = 31;

9876

// imach[3] = 2147483647;

9877

// imach[4] = 2;

9878

// imach[5] = 24;

9879

// imach[6] = -125;

9880

// imach[7] = 128;

9881

// imach[8] = 53;

9882

// imach[9] = -1021;

9883

// imach[10] = 1024;

9884

9885

// MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D

9886

// SERIES (MIPS R3000 PROCESSOR).

9887

9888

// imach[1] = 2;

9889

// imach[2] = 31;

9890

// imach[3] = 2147483647;

9891

// imach[4] = 2;

9892

// imach[5] = 24;

9893

// imach[6] = -125;

9894

// imach[7] = 128;

9895

// imach[8] = 53;

9896

// imach[9] = -1021;

9897

// imach[10] = 1024;

9898

9899

// MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T

9900

// 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T

9901

// PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300).

9902

9903

imach[1] = 2;

9904

imach[2] = 31;

9905

imach[3] = 2147483647;

9906

imach[4] = 2;

9907

imach[5] = 24;

9908

imach[6] = -125;

9909

imach[7] = 128;

9910

imach[8] = 53;

9911

imach[9] = -1021;

9912

imach[10] = 1024;

9913

9914

// MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.

9915

9916

// imach[1] = 2;

9917

// imach[2] = 35;

9918

// imach[3] = 34359738367;

9919

// imach[4] = 2;

9920

// imach[5] = 27;

9921

// imach[6] = -128;

9922

// imach[7] = 127;

9923

// imach[8] = 60;

9924

// imach[9] = -1024;

9925

// imach[10] = 1023;

9926

9927

// MACHINE CONSTANTS FOR THE VAX 11/780.

9928

9929

// imach[1] = 2;

9930

// imach[2] = 31;

9931

// imach[3] = 2147483647;

9932

// imach[4] = 2;

9933

// imach[5] = 24;

9934

// imach[6] = -127;

9935

// imach[7] = 127;

9936

// imach[8] = 56;

9937

// imach[9] = -127;

9938

// imach[10] = 127;

9939

9940

ipmpar = imach[*i];

9941

return ipmpar;

9942

}

9943

//****************************************************************************80

9944

9945

void negative_binomial_cdf_values ( int *n_data, int *f, int *s, double *p,

9946

double *cdf )

9947

9948

//****************************************************************************80

9949

9950

// Purpose:

9951

9952

// NEGATIVE_BINOMIAL_CDF_VALUES returns values of the negative binomial CDF.

9953

9954

// Discussion:

9955

9956

// Assume that a coin has a probability P of coming up heads on

9957

// any one trial. Suppose that we plan to flip the coin until we

9958

// achieve a total of S heads. If we let F represent the number of

9959

// tails that occur in this process, then the value of F satisfies

9960

// a negative binomial PDF:

9961

9962

// PDF(F,S,P) = Choose ( F from F+S-1 ) * P**S * (1-P)**F

9963

9964

// The negative binomial CDF is the probability that there are F or

9965

// fewer failures upon the attainment of the S-th success. Thus,

9966

9967

// CDF(F,S,P) = sum ( 0 <= G <= F ) PDF(G,S,P)

9968

9969

// Modified:

9970

9971

// 07 June 2004

9972

9973

// Author:

9974

9975

// John Burkardt

9976

9977

// Reference:

9978

9979

// F C Powell,

9980

// Statistical Tables for Sociology, Biology and Physical Sciences,

9981

// Cambridge University Press, 1982.

9982

9983

// Parameters:

9984

9985

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

9986

// first call. On each call, the routine increments N_DATA by 1, and

9987

// returns the corresponding data; when there is no more data, the

9988

// output value of N_DATA will be 0 again.

9989

9990

// Output, int *F, the maximum number of failures.

9991

9992

// Output, int *S, the number of successes.

9993

9994

// Output, double *P, the probability of a success on one trial.

9995

9996

// Output, double *CDF, the probability of at most F failures before the

9997

// S-th success.

9998

9999

{

10000

# define N_MAX 27

10001

10002

double cdf_vec[N_MAX] = {

10003

0.6367, 0.3633, 0.1445,

10004

0.5000, 0.2266, 0.0625,

10005

0.3438, 0.1094, 0.0156,

10006

0.1792, 0.0410, 0.0041,

10007

0.0705, 0.0109, 0.0007,

10008

0.9862, 0.9150, 0.7472,

10009

0.8499, 0.5497, 0.2662,

10010

0.6513, 0.2639, 0.0702,

10011

1.0000, 0.0199, 0.0001 };

10012

int f_vec[N_MAX] = {

10013

4, 3, 2,

10014

3, 2, 1,

10015

2, 1, 0,

10016

2, 1, 0,

10017

2, 1, 0,

10018

11, 10, 9,

10019

17, 16, 15,

10020

9, 8, 7,

10021

2, 1, 0 };

10022

double p_vec[N_MAX] = {

10023

0.50, 0.50, 0.50,

10024

0.50, 0.50, 0.50,

10025

0.50, 0.50, 0.50,

10026

0.40, 0.40, 0.40,

10027

0.30, 0.30, 0.30,

10028

0.30, 0.30, 0.30,

10029

0.10, 0.10, 0.10,

10030

0.10, 0.10, 0.10,

10031

0.01, 0.01, 0.01 };

10032

int s_vec[N_MAX] = {

10033

4, 5, 6,

10034

4, 5, 6,

10035

4, 5, 6,

10036

4, 5, 6,

10037

4, 5, 6,

10038

1, 2, 3,

10039

1, 2, 3,

10040

1, 2, 3,

10041

0, 1, 2 };

10042

10043

if ( n_data < 0 )

10044

{

10045

*n_data = 0;

10046

}

10047

10048

*n_data = *n_data + 1;

10049

10050

if ( N_MAX < *n_data )

10051

{

10052

*n_data = 0;

10053

*f = 0;

10054

*s = 0;

10055

*p = 0.0E+00;

10056

*cdf = 0.0E+00;

10057

}

10058

else

10059

{

10060

*f = f_vec[*n_data-1];

10061

*s = s_vec[*n_data-1];

10062

*p = p_vec[*n_data-1];

10063

*cdf = cdf_vec[*n_data-1];

10064

}

10065

10066

return;

10067

# undef N_MAX

10068

}

10069

//****************************************************************************80

10070

10071

void normal_cdf_values ( int *n_data, double *x, double *fx )

10072

10073

//****************************************************************************80

10074

10075

// Purpose:

10076

10077

// NORMAL_CDF_VALUES returns some values of the Normal CDF.

10078

10079

// Modified:

10080

10081

// 31 May 2004

10082

10083

// Author:

10084

10085

// John Burkardt

10086

10087

// Reference:

10088

10089

// Milton Abramowitz and Irene Stegun,

10090

// Handbook of Mathematical Functions,

10091

// US Department of Commerce, 1964.

10092

10093

// Parameters:

10094

10095

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

10096

// first call. On each call, the routine increments N_DATA by 1, and

10097

// returns the corresponding data; when there is no more data, the

10098

// output value of N_DATA will be 0 again.

10099

10100

// Output, double *X, the argument of the function.

10101

10102

// Output double *FX, the value of the function.

10103

10104

{

10105

# define N_MAX 13

10106

10107

double fx_vec[N_MAX] = {

10108

0.500000000000000E+00, 0.539827837277029E+00, 0.579259709439103E+00,

10109

0.617911422188953E+00, 0.655421741610324E+00, 0.691462461274013E+00,

10110

0.725746882249927E+00, 0.758036347776927E+00, 0.788144601416604E+00,

10111

0.815939874653241E+00, 0.841344746068543E+00, 0.933192798731142E+00,

10112

0.977249868051821E+00 };

10113

double x_vec[N_MAX] = {

10114

0.00E+00, 0.10E+00, 0.20E+00,

10115

0.30E+00, 0.40E+00, 0.50E+00,

10116

0.60E+00, 0.70E+00, 0.80E+00,

10117

0.90E+00, 1.00E+00, 1.50E+00,

10118

2.00E+00 };

10119

10120

if ( *n_data < 0 )

10121

{

10122

*n_data = 0;

10123

}

10124

10125

*n_data = *n_data + 1;

10126

10127

if ( N_MAX < *n_data )

10128

{

10129

*n_data = 0;

10130

*x = 0.0E+00;

10131

*fx = 0.0E+00;

10132

}

10133

else

10134

{

10135

*x = x_vec[*n_data-1];

10136

*fx = fx_vec[*n_data-1];

10137

}

10138

10139

return;

10140

# undef N_MAX

10141

}

10142

//****************************************************************************80

10143

10144

void poisson_cdf_values ( int *n_data, double *a, int *x, double *fx )

10145

10146

//****************************************************************************80

10147

10148

// Purpose:

10149

10150

// POISSON_CDF_VALUES returns some values of the Poisson CDF.

10151

10152

// Discussion:

10153

10154

// CDF(X)(A) is the probability of at most X successes in unit time,

10155

// given that the expected mean number of successes is A.

10156

10157

// Modified:

10158

10159

// 31 May 2004

10160

10161

// Author:

10162

10163

// John Burkardt

10164

10165

// Reference:

10166

10167

// Milton Abramowitz and Irene Stegun,

10168

// Handbook of Mathematical Functions,

10169

// US Department of Commerce, 1964.

10170

10171

// Daniel Zwillinger,

10172

// CRC Standard Mathematical Tables and Formulae,

10173

// 30th Edition, CRC Press, 1996, pages 653-658.

10174

10175

// Parameters:

10176

10177

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

10178

// first call. On each call, the routine increments N_DATA by 1, and

10179

// returns the corresponding data; when there is no more data, the

10180

// output value of N_DATA will be 0 again.

10181

10182

// Output, double *A, the parameter of the function.

10183

10184

// Output, int *X, the argument of the function.

10185

10186

// Output, double *FX, the value of the function.

10187

10188

{

10189

# define N_MAX 21

10190

10191

double a_vec[N_MAX] = {

10192

0.02E+00, 0.10E+00, 0.10E+00, 0.50E+00,

10193

0.50E+00, 0.50E+00, 1.00E+00, 1.00E+00,

10194

1.00E+00, 1.00E+00, 2.00E+00, 2.00E+00,

10195

2.00E+00, 2.00E+00, 5.00E+00, 5.00E+00,

10196

5.00E+00, 5.00E+00, 5.00E+00, 5.00E+00,

10197

5.00E+00 };

10198

double fx_vec[N_MAX] = {

10199

0.980E+00, 0.905E+00, 0.995E+00, 0.607E+00,

10200

0.910E+00, 0.986E+00, 0.368E+00, 0.736E+00,

10201

0.920E+00, 0.981E+00, 0.135E+00, 0.406E+00,

10202

0.677E+00, 0.857E+00, 0.007E+00, 0.040E+00,

10203

0.125E+00, 0.265E+00, 0.441E+00, 0.616E+00,

10204

0.762E+00 };

10205

int x_vec[N_MAX] = {

10206

0, 0, 1, 0,

10207

1, 2, 0, 1,

10208

2, 3, 0, 1,

10209

2, 3, 0, 1,

10210

2, 3, 4, 5,

10211

6 };

10212

10213

if ( *n_data < 0 )

10214

{

10215

*n_data = 0;

10216

}

10217

10218

*n_data = *n_data + 1;

10219

10220

if ( N_MAX < *n_data )

10221

{

10222

*n_data = 0;

10223

*a = 0.0E+00;

10224

*x = 0;

10225

*fx = 0.0E+00;

10226

}

10227

else

10228

{

10229

*a = a_vec[*n_data-1];

10230

*x = x_vec[*n_data-1];

10231

*fx = fx_vec[*n_data-1];

10232

}

10233

return;

10234

# undef N_MAX

10235

}

10236

//****************************************************************************80

10237

10238

double psi ( double *xx )

10239

10240

//****************************************************************************80

10241

10242

// Purpose:

10243

10244

// PSI evaluates the psi or digamma function, d/dx ln(gamma(x)).

10245

10246

// Discussion:

10247

10248

// The main computation involves evaluation of rational Chebyshev

10249

// approximations. PSI was written at Argonne National Laboratory

10250

// for FUNPACK, and subsequently modified by A. H. Morris of NSWC.

10251

10252

// Reference:

10253

10254

// William Cody, Strecok and Thacher,

10255

// Chebyshev Approximations for the Psi Function,

10256

// Mathematics of Computation,

10257

// Volume 27, 1973, pages 123-127.

10258

10259

// Parameters:

10260

10261

// Input, double *XX, the argument of the psi function.

10262

10263

// Output, double PSI, the value of the psi function. PSI

10264

// is assigned the value 0 when the psi function is undefined.

10265

10266

{

10267

static double dx0 = 1.461632144968362341262659542325721325e0;

10268

static double piov4 = .785398163397448e0;

10269

static double p1[7] = {

10270

.895385022981970e-02,.477762828042627e+01,.142441585084029e+03,

10271

.118645200713425e+04,.363351846806499e+04,.413810161269013e+04,

10272

.130560269827897e+04

10273

};

10274

static double p2[4] = {

10275

-.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01,

10276

-.648157123766197e+00

10277

};

10278

static double q1[6] = {

10279

.448452573429826e+02,.520752771467162e+03,.221000799247830e+04,

10280

.364127349079381e+04,.190831076596300e+04,.691091682714533e-05

10281

};

10282

static double q2[4] = {

10283

.322703493791143e+02,.892920700481861e+02,.546117738103215e+02,

10284

.777788548522962e+01

10285

};

10286

static int K1 = 3;

10287

static int K2 = 1;

10288

static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z;

10289

static int i,m,n,nq;

10290

10291

// MACHINE DEPENDENT CONSTANTS ...

10292

// XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT

10293

// WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED

10294

// AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE

10295

// ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH

10296

// PSI MAY BE REPRESENTED AS ALOG(X).

10297

// XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X)

10298

// MAY BE REPRESENTED BY 1/X.

10299

10300

xmax1 = ipmpar(&K1);

10301

xmax1 = fifdmin1(xmax1,1.0e0/dpmpar(&K2));

10302

xsmall = 1.e-9;

10303

x = *xx;

10304

aug = 0.0e0;

10305

if(x >= 0.5e0) goto S50;

10306

10307

// X .LT. 0.5, USE REFLECTION FORMULA

10308

// PSI(1-X) = PSI(X) + PI * COTAN(PI*X)

10309

10310

if(fabs(x) > xsmall) goto S10;

10311

if(x == 0.0e0) goto S100;

10312

10313

// 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE

10314

// FOR PI*COTAN(PI*X)

10315

10316

aug = -(1.0e0/x);

10317

goto S40;

10318

S10:

10319

10320

// REDUCTION OF ARGUMENT FOR COTAN

10321

10322

w = -x;

10323

sgn = piov4;

10324

if(w > 0.0e0) goto S20;

10325

w = -w;

10326

sgn = -sgn;

10327

S20:

10328

10329

// MAKE AN ERROR EXIT IF X .LE. -XMAX1

10330

10331

if(w >= xmax1) goto S100;

10332

nq = fifidint(w);

10333

w -= (double)nq;

10334

nq = fifidint(w*4.0e0);

10335

w = 4.0e0*(w-(double)nq*.25e0);

10336

10337

// W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X.

10338

// ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST

10339

// QUADRANT AND DETERMINE SIGN

10340

10341

n = nq/2;

10342

if(n+n != nq) w = 1.0e0-w;

10343

z = piov4*w;

10344

m = n/2;

10345

if(m+m != n) sgn = -sgn;

10346

10347

// DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X)

10348

10349

n = (nq+1)/2;

10350

m = n/2;

10351

m += m;

10352

if(m != n) goto S30;

10353

10354

// CHECK FOR SINGULARITY

10355

10356

if(z == 0.0e0) goto S100;

10357

10358

// USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND

10359

// SIN/COS AS A SUBSTITUTE FOR TAN

10360

10361

aug = sgn*(cos(z)/sin(z)*4.0e0);

10362

goto S40;

10363

S30:

10364

aug = sgn*(sin(z)/cos(z)*4.0e0);

10365

S40:

10366

x = 1.0e0-x;

10367

S50:

10368

if(x > 3.0e0) goto S70;

10369

10370

// 0.5 .LE. X .LE. 3.0

10371

10372

den = x;

10373

upper = p1[0]*x;

10374

for ( i = 1; i <= 5; i++ )

10375

{

10376

den = (den+q1[i-1])*x;

10377

upper = (upper+p1[i+1-1])*x;

10378

}

10379

den = (upper+p1[6])/(den+q1[5]);

10380

xmx0 = x-dx0;

10381

psi = den*xmx0+aug;

10382

return psi;

10383

S70:

10384

10385

// IF X .GE. XMAX1, PSI = LN(X)

10386

10387

if(x >= xmax1) goto S90;

10388

10389

// 3.0 .LT. X .LT. XMAX1

10390

10391

w = 1.0e0/(x*x);

10392

den = w;

10393

upper = p2[0]*w;

10394

for ( i = 1; i <= 3; i++ )

10395

{

10396

den = (den+q2[i-1])*w;

10397

upper = (upper+p2[i+1-1])*w;

10398

}

10399

aug = upper/(den+q2[3])-0.5e0/x+aug;

10400

S90:

10401

psi = aug+log(x);

10402

return psi;

10403

S100:

10404

10405

// ERROR RETURN

10406

10407

psi = 0.0e0;

10408

return psi;

10409

}

10410

//****************************************************************************80

10411

10412

void psi_values ( int *n_data, double *x, double *fx )

10413

10414

//****************************************************************************80

10415

10416

// Purpose:

10417

10418

// PSI_VALUES returns some values of the Psi or Digamma function.

10419

10420

// Discussion:

10421

10422

// PSI(X) = d LN ( Gamma ( X ) ) / d X = Gamma'(X) / Gamma(X)

10423

10424

// PSI(1) = - Euler's constant.

10425

10426

// PSI(X+1) = PSI(X) + 1 / X.

10427

10428

// Modified:

10429

10430

// 31 May 2004

10431

10432

// Author:

10433

10434

// John Burkardt

10435

10436

// Reference:

10437

10438

// Milton Abramowitz and Irene Stegun,

10439

// Handbook of Mathematical Functions,

10440

// US Department of Commerce, 1964.

10441

10442

// Parameters:

10443

10444

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

10445

// first call. On each call, the routine increments N_DATA by 1, and

10446

// returns the corresponding data; when there is no more data, the

10447

// output value of N_DATA will be 0 again.

10448

10449

// Output, double *X, the argument of the function.

10450

10451

// Output, double *FX, the value of the function.

10452

10453

{

10454

# define N_MAX 11

10455

10456

double fx_vec[N_MAX] = {

10457

-0.5772156649E+00, -0.4237549404E+00, -0.2890398966E+00,

10458

-0.1691908889E+00, -0.0613845446E+00, -0.0364899740E+00,

10459

0.1260474528E+00, 0.2085478749E+00, 0.2849914333E+00,

10460

0.3561841612E+00, 0.4227843351E+00 };

10461

double x_vec[N_MAX] = {

10462

1.0E+00, 1.1E+00, 1.2E+00,

10463

1.3E+00, 1.4E+00, 1.5E+00,

10464

1.6E+00, 1.7E+00, 1.8E+00,

10465

1.9E+00, 2.0E+00 };

10466

10467

if ( *n_data < 0 )

10468

{

10469

*n_data = 0;

10470

}

10471

10472

*n_data = *n_data + 1;

10473

10474

if ( N_MAX < *n_data )

10475

{

10476

*n_data = 0;

10477

*x = 0.0E+00;

10478

*fx = 0.0E+00;

10479

}

10480

else

10481

{

10482

*x = x_vec[*n_data-1];

10483

*fx = fx_vec[*n_data-1];

10484

}

10485

return;

10486

# undef N_MAX

10487

}

10488

//****************************************************************************80

10489

10490

double rcomp ( double *a, double *x )

10491

10492

//****************************************************************************80

10493

10494

// Purpose:

10495

10496

// RCOMP evaluates exp(-X) * X**A / Gamma(A).

10497

10498

// Parameters:

10499

10500

// Input, double *A, *X, arguments of the quantity to be computed.

10501

10502

// Output, double RCOMP, the value of exp(-X) * X**A / Gamma(A).

10503

10504

// Local parameters:

10505

10506

// RT2PIN = 1/SQRT(2*PI)

10507

10508

{

10509

static double rt2pin = .398942280401433e0;

10510

static double rcomp,t,t1,u;

10511

rcomp = 0.0e0;

10512

if(*a >= 20.0e0) goto S20;

10513

t = *a*log(*x)-*x;

10514

if(*a >= 1.0e0) goto S10;

10515

rcomp = *a*exp(t)*(1.0e0+gam1(a));

10516

return rcomp;

10517

S10:

10518

rcomp = exp(t)/ gamma_x(a);

10519

return rcomp;

10520

S20:

10521

u = *x/ *a;

10522

if(u == 0.0e0) return rcomp;

10523

t = pow(1.0e0/ *a,2.0);

10524

t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);

10525

t1 -= (*a*rlog(&u));

10526

rcomp = rt2pin*sqrt(*a)*exp(t1);

10527

return rcomp;

10528

}

10529

//****************************************************************************80

10530

10531

double rexp ( double *x )

10532

10533

//****************************************************************************80

10534

10535

// Purpose:

10536

10537

// REXP evaluates the function EXP(X) - 1.

10538

10539

// Modified:

10540

10541

// 09 December 1999

10542

10543

// Parameters:

10544

10545

// Input, double *X, the argument of the function.

10546

10547

// Output, double REXP, the value of EXP(X)-1.

10548

10549

{

10550

static double p1 = .914041914819518e-09;

10551

static double p2 = .238082361044469e-01;

10552

static double q1 = -.499999999085958e+00;

10553

static double q2 = .107141568980644e+00;

10554

static double q3 = -.119041179760821e-01;

10555

static double q4 = .595130811860248e-03;

10556

static double rexp,w;

10557

10558

if(fabs(*x) > 0.15e0) goto S10;

10559

rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0));

10560

return rexp;

10561

S10:

10562

w = exp(*x);

10563

if(*x > 0.0e0) goto S20;

10564

rexp = w-0.5e0-0.5e0;

10565

return rexp;

10566

S20:

10567

rexp = w*(0.5e0+(0.5e0-1.0e0/w));

10568

return rexp;

10569

}

10570

//****************************************************************************80

10571

10572

double rlog ( double *x )

10573

10574

//****************************************************************************80

10575

10576

// Purpose:

10577

10578

// RLOG computes X - 1 - LN(X).

10579

10580

// Modified:

10581

10582

// 09 December 1999

10583

10584

// Parameters:

10585

10586

// Input, double *X, the argument of the function.

10587

10588

// Output, double RLOG, the value of the function.

10589

10590

{

10591

static double a = .566749439387324e-01;

10592

static double b = .456512608815524e-01;

10593

static double p0 = .333333333333333e+00;

10594

static double p1 = -.224696413112536e+00;

10595

static double p2 = .620886815375787e-02;

10596

static double q1 = -.127408923933623e+01;

10597

static double q2 = .354508718369557e+00;

10598

static double rlog,r,t,u,w,w1;

10599

10600

if(*x < 0.61e0 || *x > 1.57e0) goto S40;

10601

if(*x < 0.82e0) goto S10;

10602

if(*x > 1.18e0) goto S20;

10603

10604

// ARGUMENT REDUCTION

10605

10606

u = *x-0.5e0-0.5e0;

10607

w1 = 0.0e0;

10608

goto S30;

10609

S10:

10610

u = *x-0.7e0;

10611

u /= 0.7e0;

10612

w1 = a-u*0.3e0;

10613

goto S30;

10614

S20:

10615

u = 0.75e0**x-1.e0;

10616

w1 = b+u/3.0e0;

10617

S30:

10618

10619

// SERIES EXPANSION

10620

10621

r = u/(u+2.0e0);

10622

t = r*r;

10623

w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);

10624

rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;

10625

return rlog;

10626

S40:

10627

r = *x-0.5e0-0.5e0;

10628

rlog = r-log(*x);

10629

return rlog;

10630

}

10631

//****************************************************************************80

10632

10633

double rlog1 ( double *x )

10634

10635

//****************************************************************************80

10636

10637

// Purpose:

10638

10639

// RLOG1 evaluates the function X - ln ( 1 + X ).

10640

10641

// Parameters:

10642

10643

// Input, double *X, the argument.

10644

10645

// Output, double RLOG1, the value of X - ln ( 1 + X ).

10646

10647

{

10648

static double a = .566749439387324e-01;

10649

static double b = .456512608815524e-01;

10650

static double p0 = .333333333333333e+00;

10651

static double p1 = -.224696413112536e+00;

10652

static double p2 = .620886815375787e-02;

10653

static double q1 = -.127408923933623e+01;

10654

static double q2 = .354508718369557e+00;

10655

static double rlog1,h,r,t,w,w1;

10656

10657

if(*x < -0.39e0 || *x > 0.57e0) goto S40;

10658

if(*x < -0.18e0) goto S10;

10659

if(*x > 0.18e0) goto S20;

10660

10661

// ARGUMENT REDUCTION

10662

10663

h = *x;

10664

w1 = 0.0e0;

10665

goto S30;

10666

S10:

10667

h = *x+0.3e0;

10668

h /= 0.7e0;

10669

w1 = a-h*0.3e0;

10670

goto S30;

10671

S20:

10672

h = 0.75e0**x-0.25e0;

10673

w1 = b+h/3.0e0;

10674

S30:

10675

10676

// SERIES EXPANSION

10677

10678

r = h/(h+2.0e0);

10679

t = r*r;

10680

w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);

10681

rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;

10682

return rlog1;

10683

S40:

10684

w = *x+0.5e0+0.5e0;

10685

rlog1 = *x-log(w);

10686

return rlog1;

10687

}

10688

//****************************************************************************80

10689

10690

void student_cdf_values ( int *n_data, int *a, double *x, double *fx )

10691

10692

//****************************************************************************80

10693

10694

// Purpose:

10695

10696

// STUDENT_CDF_VALUES returns some values of the Student CDF.

10697

10698

// Modified:

10699

10700

// 31 May 2004

10701

10702

// Author:

10703

10704

// John Burkardt

10705

10706

// Reference:

10707

10708

// Milton Abramowitz and Irene Stegun,

10709

// Handbook of Mathematical Functions,

10710

// US Department of Commerce, 1964.

10711

10712

// Parameters:

10713

10714

// Input/output, int *N_DATA. The user sets N_DATA to 0 before the

10715

// first call. On each call, the routine increments N_DATA by 1, and

10716

// returns the corresponding data; when there is no more data, the

10717

// output value of N_DATA will be 0 again.

10718

10719

// Output, int *A, the parameter of the function.

10720

10721

// Output, double *X, the argument of the function.

10722

10723

// Output, double *FX, the value of the function.

10724

10725

{

10726

# define N_MAX 13

10727

10728

int a_vec[N_MAX] = {

10729

1, 2, 3, 4,

10730

5, 2, 5, 2,

10731

5, 2, 3, 4,

10732

5 };

10733

double fx_vec[N_MAX] = {

10734

0.60E+00, 0.60E+00, 0.60E+00, 0.60E+00,

10735

0.60E+00, 0.75E+00, 0.75E+00, 0.95E+00,

10736

0.95E+00, 0.99E+00, 0.99E+00, 0.99E+00,

10737

0.99E+00 };

10738

double x_vec[N_MAX] = {

10739

0.325E+00, 0.289E+00, 0.277E+00, 0.271E+00,

10740

0.267E+00, 0.816E+00, 0.727E+00, 2.920E+00,

10741

2.015E+00, 6.965E+00, 4.541E+00, 3.747E+00,

10742

3.365E+00 };

10743

10744

if ( *n_data < 0 )

10745

{

10746

*n_data = 0;

10747

}

10748

10749

*n_data = *n_data + 1;

10750

10751

if ( N_MAX < *n_data )

10752

{

10753

*n_data = 0;

10754

*a = 0;

10755

*x = 0.0E+00;

10756

*fx = 0.0E+00;

10757

}

10758

else

10759

{

10760

*a = a_vec[*n_data-1];

10761

*x = x_vec[*n_data-1];

10762

*fx = fx_vec[*n_data-1];

10763

}

10764

10765

return;

10766

# undef N_MAX

10767

}

10768

//****************************************************************************80

10769

10770

double stvaln ( double *p )

10771

10772

//****************************************************************************80

10773

10774

// Purpose:

10775

10776

// STVALN provides starting values for the inverse of the normal distribution.

10777

10778

// Discussion:

10779

10780

// The routine returns X such that

10781

// P = CUMNOR(X),

10782

// that is,

10783

// P = Integral from -infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU.

10784

10785

// Reference:

10786

10787

// Kennedy and Gentle,

10788

// Statistical Computing,

10789

// Marcel Dekker, NY, 1980, page 95,

10790

// QA276.4 K46

10791

10792

// Parameters:

10793

10794

// Input, double *P, the probability whose normal deviate

10795

// is sought.

10796

10797

// Output, double STVALN, the normal deviate whose probability

10798

// is P.

10799

10800

{

10801

static double xden[5] = {

10802

0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0,

10803

0.38560700634e-2

10804

};

10805

static double xnum[5] = {

10806

-0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1,

10807

-0.453642210148e-4

10808

};

10809

static int K1 = 5;

10810

static double stvaln,sign,y,z;

10811

10812

if(!(*p <= 0.5e0)) goto S10;

10813

sign = -1.0e0;

10814

z = *p;

10815

goto S20;

10816

S10:

10817

sign = 1.0e0;

10818

z = 1.0e0-*p;

10819

S20:

10820

y = sqrt(-(2.0e0*log(z)));

10821

stvaln = y+ eval_pol ( xnum, &K1, &y ) / eval_pol ( xden, &K1, &y );

10822

stvaln = sign*stvaln;

10823

return stvaln;

10824

}

10825

//**************************************************************************80

10826

10827

#if !defined(TIMESTAMP)

10828

#define TIMESTAMP

10829

void timestamp ( )

10830

10831

//**************************************************************************80

10832

10833

// Purpose:

10834

10835

// TIMESTAMP prints the current YMDHMS date as a time stamp.

10836

10837

// Example:

10838

10839

// May 31 2001 09:45:54 AM

10840

10841

// Modified:

10842

10843

// 24 September 2003

10844

10845

// Author:

10846

10847

// John Burkardt

10848

10849

// Parameters:

10850

10851

// None

10852

10853

{

10854

# define TIME_SIZE 40

10855

10856

static char time_buffer[TIME_SIZE];

10857

const struct tm *tm;

10858

size_t len;

10859

time_t now;

10860

10861

now = time ( NULL );

10862

tm = localtime ( &now );

10863

10864

len = strftime ( time_buffer, TIME_SIZE, "%d %B %Y %I:%M:%S %p", tm );

10865

10866

cout << time_buffer << "\n";

10867

10868

return;

10869

# undef TIME_SIZE

10870

}

10871

10872

10873

#endif

Older »