void UpdateBeta(vec& beta, mat& rho_m, int V, int K){
double NEWTON_THRESH = 0.00001;
int MAX_ITER = 1000;
double gamma = 0.001;
vec df(V, fill::zeros);
vec g(V, fill::zeros);
vec h(V, fill::zeros);
int iter = 0;
do{
// compute the first derivative
double digamma_beta = digamma(sum(beta));
double digamma_theta = 0;
for(int k = 0; k < K; k++){
digamma_theta += digamma(sum(rho_m.row(k)));
}
for(int w = 0; w < V; w++){
double temp = 0;
for(int k = 0; k < K; k++){
temp += digamma(rho_m(k, w));
}
g(w) = K * (digamma_beta - digamma(beta(w))) + temp - digamma_theta;
}
cout << "this is g" << endl;
cout << g.t() << endl;
// compute the Hessian
double trigamma_beta = trigamma(sum(beta));
for(int w = 0; w < V; w++){
h(w) = K * trigamma(beta(w));
}
cout << "this is h" << endl;
cout << h.t() << endl;
// compute constant terms needed for gradient
double c = sum(g / h) / (- 1 / trigamma_beta + sum(1 / h));
for(int w = 0; w < V; w++){
df(w) = (g(w) - c) / h(w);
}
beta -= gamma * df;
iter++;
cout << "iteration: " << iter << endl;
cout << beta.t() << endl;
} while(iter < MAX_ITER && max(abs(df)) > NEWTON_THRESH);
return;
}
inline var<AutodiffOrder, StrictSmoothness, ValidateIO>
lgamma(const var<AutodiffOrder, StrictSmoothness, ValidateIO>& input) {
if (ValidateIO) validate_input(input.first_val(), "lgamma");
const short partials_order = 3;
const unsigned int n_inputs = 1;
create_node<unary_var_node<AutodiffOrder, partials_order>>(n_inputs);
double val = input.first_val();
try {
push_dual_numbers<AutodiffOrder, ValidateIO>(lgamma(val));
} catch (nomad_error) {
throw nomad_output_value_error("lgamma");
}
push_inputs(input.dual_numbers());
try {
if (AutodiffOrder >= 1) push_partials<ValidateIO>(digamma(val));
if (AutodiffOrder >= 2) push_partials<ValidateIO>(trigamma(val));
if (AutodiffOrder >= 3) push_partials<ValidateIO>(quadrigamma(val));
} catch (nomad_error) {
throw nomad_output_partial_error("lgamma");
}
return var<AutodiffOrder, StrictSmoothness, ValidateIO>(next_node_idx_ - 1);
}
void test01 ( void )
/******************************************************************************/
/*
Purpose:
TEST01 demonstrates the use of TRIGAMMA.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
19 January 2008
Author:
John Burkardt
*/
{
double fx;
double fx2;
int ifault;
int n_data;
double x;
printf ( "\n" );
printf ( "TEST01:\n" );
printf ( " TRIGAMMA computes the trigamma function. \n" );
printf ( " We compare the result to tabulated values.\n" );
printf ( "\n" );
printf ( " X " );
printf ( "FX FX2\n" );
printf ( " " );
printf ( "(Tabulated) (TRIGAMMA) DIFF\n" );
printf ( "\n" );
n_data = 0;
for ( ; ; )
{
trigamma_values ( &n_data, &x, &fx );
if ( n_data == 0 )
{
break;
}
fx2 = trigamma ( x, &ifault );
printf ( " %24.16f %24.16f %24.16f %10.4g\n",
x, fx, fx2, fabs ( fx - fx2 ) );
}
return;
}
static void diffset(void) {
int i;
for (i=3; i<FDIM; i++) {
fg[i] = lgamma(i);
fp0[i] = digamma(i);
fp1[i] = trigamma(i);
fp2[i] = tetragamma(i);
fp3[i] = pentagamma(i);
}
fset = 1;
}
double
eval_zinb_dgda
(
double a,
double p,
const tab_t * tab
)
{
// Convenience variables.
const unsigned int *val = tab->val;
const unsigned int *num = tab->num;
const double ppa = pow(p,a);
unsigned int nz = 0;
double retval = 0.0;
double prev = trigamma(a + val[0]);
if (val[0] > 0) {
retval += num[0] * prev;
nz += num[0];
}
// Iterate over the occurrences and compute the new value
// of digamma either by the recurrence relation, or by
// a new call to 'trigamma()', whichever is faster.
const size_t imin = val[0] == 0 ? 1 : 0;
for (size_t i = imin ; i < tab->size ; i++) {
nz += num[i];
prev = (val[i] - val[i-1] == 1) ?
prev - 1.0 / sq(a-1 + val[i]) :
trigamma(a + val[i]);
retval += num[i] * prev;
}
retval += nz*(sq(log(p))*ppa / sq(1-ppa) - trigamma(a));
return retval;
}
double BM::Loglike(const Vector &ab, Vec &g, Mat &h, uint nd) const{
if (ab.size() != 2) {
report_error("Wrong size argument.");
}
double alpha = ab[0];
double beta = ab[1];
if (alpha <= 0 || beta <= 0) {
if (nd > 0) {
g[0] = (alpha <= 0) ? 1.0 : 0.0;
g[1] = (beta <= 0) ? 1.0 : 0.0;
if (nd > 1) {
h = 0.0;
h.diag() = -1.0;
}
}
return negative_infinity();
}
double n = suf()->n();
double sumlog = suf()->sumlog();
double sumlogc = suf()->sumlogc();
double ans = n*(lgamma(alpha + beta) - lgamma(alpha)-lgamma(beta));
ans += (alpha-1)*sumlog + (beta-1)*sumlogc;
if(nd>0){
double psisum = digamma(alpha + beta);
g[0] = n*(psisum-digamma(alpha)) + sumlog;
g[1] = n*(psisum-digamma(beta)) + sumlogc;
if(nd>1){
double trisum = trigamma(alpha+beta);
h(0,0) = n*(trisum - trigamma(alpha));
h(0,1) = h(1,0) = n*trisum;
h(1,1) = n*(trisum - trigamma(beta));}}
return ans;
}
double
eval_nb_dfda
(
double a,
const tab_t *tab
)
{
double retval;
double prev;
// Convenience variables.
const unsigned int *val = tab->val;
const unsigned int *num = tab->num;
size_t nobs = num[0];
double mean = num[0] * val[0];
prev = trigamma(a + val[0]);
retval = num[0] * prev;
// Iterate over the occurrences and compute the new value
// of trigamma either by the recurrence relation, or by
// a new call to 'trigamma()', whichever is faster.
for (size_t i = 1 ; i < tab->size ; i++) {
nobs += num[i];
mean += num[i] * val[i];
prev = (val[i] - val[i-1] == 1) ?
prev - 1.0 / sq(a-1 +val[i]) :
trigamma(a + val[i]);
retval += num[i] * prev;
}
mean /= nobs;
retval += nobs*(mean/(a*(a+mean)) - trigamma(a));
return retval;
}
/* The trigamma function is the derivative of the digamma function.
Reference:
B Schneider,
Trigamma Function,
Algorithm AS 121,
Applied Statistics,
Volume 27, Number 1, page 97-99, 1978.
From http://www.psc.edu/~burkardt/src/dirichlet/dirichlet.f
(with modification for negative arguments and extra precision)
*/
double trigamma(double x)
{
double result;
double neginf = -1.0/0.0,
small = 1e-4,
large = 8,
c = 1.6449340668482264365, /* pi^2/6 = Zeta(2) */
c1 = -2.404113806319188570799476, /* -2 Zeta(3) */
b2 = 1./6,
b4 = -1./30,
b6 = 1./42,
b8 = -1./30,
b10 = 5./66;
/* Illegal arguments */
if((x == neginf) || isnan(x)) {
return 0.0/0.0;
}
/* Singularities */
if((x <= 0) && (floor(x) == x)) {
return -neginf;
}
/* Negative values */
/* Use the derivative of the digamma reflection formula:
* -trigamma(-x) = trigamma(x+1) - (pi*csc(pi*x))^2
*/
if(x < 0) {
result = M_PI/sin(-M_PI*x);
return -trigamma(1-x) + result*result;
}
/* Use Taylor series if argument <= small */
if(x <= small) {
return 1/(x*x) + c + c1*x;
}
result = 0;
/* Reduce to trigamma(x+n) where ( X + N ) >= B */
while(x < large) {
result += 1/(x*x);
x++;
}
/* Apply asymptotic formula when X >= B */
/* This expansion can be computed in Maple via asympt(Psi(1,x),x) */
if(x >= large) {
double r = 1/(x*x);
result += 0.5*r + (1 + r*(b2 + r*(b4 + r*(b6 + r*(b8 + r*b10)))))/x;
}
return result;
}
void mexFunction(int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[])
{
int ndims, len, i, nnz;
int *dims;
double *indata, *outdata;
if((nrhs != 1) || (nlhs > 1))
mexErrMsgTxt("Usage: x = trigamma(n)");
/* prhs[0] is first argument.
* mxGetPr returns double* (data, col-major)
* mxGetM returns int (rows)
* mxGetN returns int (cols)
*/
ndims = mxGetNumberOfDimensions(prhs[0]);
dims = (int*)mxGetDimensions(prhs[0]);
indata = mxGetPr(prhs[0]);
len = mxGetNumberOfElements(prhs[0]);
if(mxIsSparse(prhs[0])) {
plhs[0] = mxDuplicateArray(prhs[0]);
/* number of nonzero entries */
nnz = mxGetJc(prhs[0])[mxGetN(prhs[0])];
if(nnz != mxGetNumberOfElements(prhs[0])) {
mexErrMsgTxt("Cannot handle sparse n.");
}
} else {
/* plhs[0] is first output */
plhs[0] = mxCreateNumericArray(ndims, dims, mxDOUBLE_CLASS, mxREAL);
}
outdata = mxGetPr(plhs[0]);
/* compute trigamma of every element */
for(i=0;i<len;i++)
*outdata++ = trigamma(*indata++);
}
double d2_alhood(double a, double alpha_sum, int D, int K)
{ return(D * (trigamma(alpha_sum) - trigamma(a))); }
double d2_alhood(double a, int D, int K)
{ return(D * (K * K * trigamma(K * a) - K * trigamma(a))); }
inline typename tools::promote_args<T>::type
trigamma(T x)
{
return trigamma(x, policies::policy<>());
}
void diff2PDF_nu_tCopula_new(double* u, double* v, int* n, double* param, int* copula, double* out)
{
double out1=0, out2=0, out3=0, out4=0, x1, x2, diff_nu=0;
int j=0, k=1;
double t1, t2, t3, t4, t5, t6, t8, t9, t10, t11, t12, t13, t14, t15, t16, t17, t18, t19, t20, t21, t22, t23, t24, t25, M_nu, M, M_nu_nu, c;
double rho = param[0];
double nu = param[1];
t1=(nu+1.0)/2.0;
t2=nu/2.0;
t23=nu*nu;
t3=1.0/t23;
t4=1.0/(2.0*nu);
t5=0.5*trigamma(t1);
t6=(1.0-rho*rho);
t9=0.5*trigamma(t2);
t10=-t5+t9-t3-t4;
for(j=0;j<*n;j++)
{
LL(copula, &k, &u[j], &v[j], &rho, &nu, &c);
c=exp(c);
x1=qt(u[j],nu,1,0);
x2=qt(v[j],nu,1,0);
diffX_nu_tCopula(&x1, param, &out1);
diffX_nu_tCopula(&x2, param, &out2);
M = ( nu*t6 + x1*x1 + x2*x2 - 2.0*rho*x1*x2 );
t8=(x1*out2+out1*x2);
M_nu=t6+2.0*x1*out1+2.0*x2*out2-2.0*rho*t8;
t24=x1*x1;
t25=x2*x2;
t11=1.0+2.0*x1*out1;
t12=nu+t24;
t13=t11/t12;
t14=1.0+2.0*x2*out2;
t15=nu+t25;
t16=t14/t15;
diff2_x_nu(&x1,&nu,&out3);
diff2_x_nu(&x2,&nu,&out4);
t17=2.0*out1*out1 + 2.0*x1*out3;
t18=t17/t12;
t19=2.0*out2*out2 + 2.0*x2*out4;
t20=t19/t15;
t21=t13*t13;
t22=t16*t16;
M_nu_nu=2.0*out1*out1 + 2.0*x1*out3 + 2.0*out2*out2 + 2.0*x2*out4 - 4.0*rho*out1*out2 - 2.0*rho*(x2*out3 + x1*out4);
diffPDF_nu_tCopula_new(&u[j], &v[j], &k, param, copula, &diff_nu);
out[j]=c*( t10+0.5*(t13+t16) + t1*(t18-t21+t20-t22) + 0.5*t13 + 0.5*t16 - M_nu/M - (nu/2.0+1.0)*(M_nu_nu/M-M_nu*M_nu/M/M )) + diff_nu*diff_nu/c;
}
}
void train() {
/* initialize output */
printf("init train\n");
initTrain();
/* initialize temp variables */
double *myalpha_new = (double *) malloc(sizeof(double)*K);
double *psi_sum_beta = (double *) malloc(sizeof(double)*M);
double *psi_myalpha = (double *) malloc(sizeof(double)*K);
double **log_myrho = (double **) malloc(sizeof(double*)*M);
double **psi_mybeta = (double **) malloc(sizeof(double*)*M);
for (int m = 0; m < M; m++) {
log_myrho[m] = (double *) malloc(sizeof(double)*K);
psi_mybeta[m] = (double *) malloc(sizeof(double)*K);
}
double **old_mytheta = (double **) malloc(sizeof(double*)*K);
double **log_mytheta = (double **) malloc(sizeof(double*)*K);
double **log_inv_mytheta = (double **) malloc(sizeof(double*)*K);
for (int k = 0; k < K; k++) {
old_mytheta[k] = (double *) malloc(sizeof(double)*L);
for (int l = 0; l < L; l++) old_mytheta[k][l] = 0;
log_mytheta[k] = (double *) malloc(sizeof(double)*L);
log_inv_mytheta[k] = (double *) malloc(sizeof(double)*L);
}
double *g = (double *) malloc(sizeof(double)*K);
double *q = (double *) malloc(sizeof(double)*K);
double maxDiff = 0;
for (int out_iter = 0; out_iter < OUT_LOOP; out_iter++) {
if (out_iter % 100 == 0) printf("Iter: %d\n", out_iter);
for (int k = 0; k < K; k++) {
for (int l = 0; l < L; l++) {
#ifdef NEW_PRIOR
if (A[l] == 0) continue;
#endif
log_mytheta[k][l] = log(mytheta[k][l]);
//printf("%lf ", log(mytheta[k][l]));
log_inv_mytheta[k][l] = log(1-mytheta[k][l]);
}
//printf("\n");
}
/* e-step */
// for (int in_iter = 0; in_iter < IN_LOOP; in_iter++) {
//printf("in iter: %d\n", in_iter);
#pragma omp parallel shared(M,N,K,L,mybeta,psi_mybeta,log_myrho,log_mytheta,log_inv_mytheta,r)
{
#pragma omp for schedule(dynamic,1)
for (int m = 0; m < M; m++) {
/* computer r */
double sum_beta = 0;
for (int k = 0; k < K; k++) {
sum_beta += mybeta[m][k];
psi_mybeta[m][k] = DiGamma_Function(mybeta[m][k]);
}
psi_sum_beta[m] = DiGamma_Function(sum_beta);
for (int n = 0; n < N[m]; n++) {
for (int k = 0; k < K; k++) {
log_myrho[m][k] = psi_mybeta[m][k]-psi_sum_beta[m];
for (int l = 0; l < L; l++) {
#ifdef NEW_PRIOR
if (A[l] == 0) continue;
#endif
if (R[m][n][l]) {
log_myrho[m][k] += log_mytheta[k][l];
} else {
log_myrho[m][k] += log_inv_mytheta[k][l];
}
}
}
double log_sum_rho = logsumexp(log_myrho[m], K);
for (int k = 0; k < K; k++) {
r[m][n][k] = exp(log_myrho[m][k] - log_sum_rho);
}
}
/* compute mybeta */
for (int k = 0; k < K; k++) {
mybeta[m][k] = myalpha[k];
for (int n = 0; n < N[m]; n++) {
mybeta[m][k] = mybeta[m][k] + r[m][n][k];
}
}
}
}
/*
printf("beta:\n");
for (int m = 0; m < M; m++) {
for (int k = 0; k < K; k++) {
printf("%lf ", mybeta[m][k]);
}
printf("\n");
}
*/
// }
#ifdef DEBUG
printf("beta:\n");
for (int m = 0; m < M; m++) {
for (int k = 0; k < K; k++) {
printf("%lf ", mybeta[m][k]);
}
printf("\n");
}
#endif
/* m-step */
if (out_iter != OUT_LOOP - 1) {
/* update alpha */
if (mode == UPDATE_ALPHA) {
for (int m = 0; m < M; m++) {
double sum_beta = 0;
for (int k = 0; k < K; k++) {
sum_beta += mybeta[m][k];
psi_mybeta[m][k] = DiGamma_Function(mybeta[m][k]);
}
psi_sum_beta[m] = DiGamma_Function(sum_beta);
}
int converge = 0;
for (int iter = 0; iter < 1000; iter++) {
double sum_alpha = 0;
for (int k = 0; k < K; k++) {
sum_alpha += myalpha[k];
psi_myalpha[k] = DiGamma_Function(myalpha[k]);
}
double psi_sum_alpha = DiGamma_Function(sum_alpha);
int fault;
for (int k = 0; k < K; k++) {
g[k] = M * (psi_sum_alpha - psi_myalpha[k]);
for (int m = 0; m < M; m++) {
g[k] += psi_mybeta[m][k] - psi_sum_beta[m];
}
q[k] = -M * trigamma(myalpha[k], &fault);
}
double z = M * trigamma(sum_alpha, &fault);
double gq = 0;
double rq = 0;
for (int k = 0; k < K; k++) {
gq = gq + g[k] / q[k];
rq = rq + 1 / q[k];
}
double b = gq / (1 / z + rq);
for (int k = 0; k < K; k++) {
myalpha_new[k] = myalpha[k] - (g[k] - b) / q[k];
if (myalpha_new[k] < 0) {
printf("warning alpha small than zero\n");
}
}
#ifdef DEBUG
printf("alpha:\n");
for (int k = 0; k < K; k++) {
printf("%lf ", myalpha[k]);
}
printf("\n");
#endif
converge = 1;
for (int k = 0; k < K; k++) {
double diff = myalpha_new[k] - myalpha[k];
if (diff > 1e-6 || diff < -1e-6) {
converge = 0;
break;
}
}
if (converge) {
break;
}
double *tmpalpha = myalpha;
myalpha = myalpha_new;
myalpha_new = tmpalpha;
}
if (!converge) {
printf("warning: not converge\n");
}
}
/* update theta */
#pragma omp parallel shared(K,N,L,M,mytheta,r,R)
{
#pragma omp for schedule(dynamic,1)
for (int k = 0; k < K; k++) {
for (int l = 0; l < L; l++) {
double rR = 0;
double sum_r = 0;
#ifdef PRIOR
rR += A;
sum_r += A + B;
#endif
#ifdef NEW_PRIOR
if (A[l] == 0) continue;
rR += A[l];
sum_r += A[l] + B[l];
#endif
for (int m = 0; m < M; m++) {
for (int n = 0; n < N[m]; n++) {
rR += r[m][n][k]*R[m][n][l];
sum_r += r[m][n][k];
}
}
mytheta[k][l] = rR / sum_r;
if (EQUAL(rR,0.0)) {
mytheta[k][l] = 0;
}
if (mytheta[k][l] < 0 || mytheta[k][l] > 1 || mytheta[k][l] != mytheta[k][l]) {
printf("error %lf %lf\n", rR, sum_r);
}
}
}
}
maxDiff = 0;
for (int k = 0; k < K; k++ ){
for (int l = 0; l < L; l++) {
#ifdef NEW_PRIOR
if (A[l] == 0) continue;
#endif
double diff = old_mytheta[k][l] - mytheta[k][l];
if (diff > maxDiff) maxDiff = diff;
if (-diff > maxDiff) maxDiff = -diff;
old_mytheta[k][l] = mytheta[k][l];
}
}
if (maxDiff < 1e-6) {
printf("Finished.\n");
break;
}
#ifdef DEBUG
printf("theta:\n");
for (int k = 0; k < K; k++) {
for (int l = 0; l < L; l++) {
printf("%lf ", mytheta[k][l]);
}
printf("\n");
}
#endif
}
}
/* free temp variables */
free(g);
free(q);
for (int k = 0; k < K; k++) {
free(log_inv_mytheta[k]);
free(log_mytheta[k]);
free(old_mytheta[k]);
}
free(old_mytheta);
free(log_inv_mytheta);
free(log_mytheta);
for (int m = 0; m < M; m++) {
free(psi_mybeta[m]);
free(log_myrho[m]);
}
free(psi_mybeta);
free(log_myrho);
free(psi_sum_beta);
free(psi_myalpha);
free(myalpha_new);
}
static inline T fun(const T& x) {
return trigamma(x);
}
void inbeder(double* x_in, double* p_in, double* q_in, double* der)
{
double lbet, pa, pa1, pb, pb1, pab, pab1, err=1e-12;
double p, q, x;
int minappx=3, maxappx=200, n=0;
// falls x>p/(p+q)
if (*x_in>*p_in/(*p_in+*q_in))
{
x=1-*x_in;
p=*q_in;
q=*p_in;
}
else
{
x=*x_in;
p=*p_in;
q=*q_in;
}
// Compute Log Beta, digamma, and trigamma functions
lbet=lbeta(p,q);
pa=digamma(p);
pa1=trigamma(p);
pb=digamma(q);
pb1=trigamma(q);
pab=digamma(p+q);
pab1=trigamma(p+q);
double omx=1-x;
double logx=log(x);
double logomx=log(omx);
// Compute derivatives of K(x,p,q)=x^p(1-x)^(q-1)/[p beta(p,q)
double *c;
double c0, d;
c=Calloc(3,double);
c[0]=p*logx+(q-1)*logomx-lbet-log(p);
c0=exp(c[0]);
if (*x_in>*p_in/(*p_in+*q_in))
{
c[1]=logomx-pb+pab;
c[2]=c[1]*c[1]-pb1+pab1;
}
else
{
c[1]=logx-1/p-pa+pab;
c[2]=c[1]*c[1]+1/p/p-pa1+pab1;
}
int del=1, i=0;
double *an, *bn, *an1, *an2, *bn1, *bn2, *dr;
an=Calloc(3,double);
bn=Calloc(3,double);
an1=Calloc(3,double);
bn1=Calloc(3,double);
an2=Calloc(3,double);
bn2=Calloc(3,double);
dr=Calloc(3,double);
double *dan, *dbn, *der_old, *d1;
dan=Calloc(3,double);
dbn=Calloc(3,double);
der_old=Calloc(3,double);
d1=Calloc(3,double);
double Rn=0, pr=0;
an1[0]=1;
an2[0]=1;
bn1[0]=1;
bn2[0]=0;
der_old[0]=0;
for(i=1;i<3;i++)
{
an1[i]=0;
an2[i]=0;
bn1[i]=0;
bn2[i]=0;
der_old[i]=0;
}
while(del==1)
{
n++;
if(n==1)
{
if (*x_in>*p_in/(*p_in+*q_in))
{
incompleBeta_an1_bn1_q(&x, p, q, an, bn);
}
else
{
incompleBeta_an1_bn1_p(&x, p, q, an, bn);
}
}
else
{
if (*x_in>*p_in/(*p_in+*q_in))
{
incompleBeta_an_bn_q(&x, p, q, n, an, bn);
}
else
{
incompleBeta_an_bn_p(&x, p, q, n, an, bn);
}
}
// Use forward recurrance relations to compute An, Bn, and their derivatives
dan[0]=an[0]*an2[0]+bn[0]*an1[0];
dbn[0]=an[0]*bn2[0]+bn[0]*bn1[0];
dan[1]=an[1]*an2[0]+an[0]*an2[1]+bn[1]*an1[0]+bn[0]*an1[1];
dbn[1]=an[1]*bn2[0]+an[0]*bn2[1]+bn[1]*bn1[0]+bn[0]*bn1[1];
dan[2]=an[2]*an2[0]+2*an[1]*an2[1]+an[0]*an2[2]+bn[2]*an1[0]+2*bn[1]*an1[1]+bn[0]*an1[2];
dbn[2]=an[2]*bn2[0]+2*an[1]*bn2[1]+an[0]*bn2[2]+bn[2]*bn1[0]+2*bn[1]*bn1[1]+bn[0]*bn1[2];
// Scale derivatives to prevent overflow
Rn=dan[0];
if(fabs(dbn[0])>fabs(dan[0]))
{
Rn=dbn[0];
}
for(i=0;i<3;i++)
{
an1[i]=an1[i]/Rn;
bn1[i]=bn1[i]/Rn;
}
dan[1]=dan[1]/Rn;
dan[2]=dan[2]/Rn;
dbn[1]=dbn[1]/Rn;
dbn[2]=dbn[2]/Rn;
if(fabs(dbn[0])>fabs(dan[0]))
{
dan[0]=dan[0]/dbn[0];
dbn[0]=1;
}
else
{
dbn[0]=dbn[0]/dan[0];
dan[0]=1;
}
// Compute components of derivatives of the nth approximant
dr[0]=dan[0]/dbn[0];
Rn=dr[0];
dr[1]=(dan[1]-Rn*dbn[1])/dbn[0];
dr[2]=(-2*dan[1]*dbn[1]+2*Rn*dbn[1]*dbn[1])/dbn[0]/dbn[0]+(dan[2]-Rn*dbn[2])/dbn[0];
// Save terms corresponding to approximants n-1 and n-2
for(i=0;i<3;i++)
{
an2[i]=an1[i];
an1[i]=dan[i];
bn2[i]=bn1[i];
bn1[i]=dbn[i];
}
// Compute nth approximants
pr=0;
if(dr[0]>0)
{
pr=exp(c[0]+log(dr[0]));
}
der[0]=pr;
der[1]=pr*c[1]+c0*dr[1];
der[2]=pr*c[2]+2*c0*c[1]*dr[1]+c0*dr[2];
// Check for convergence, check for maximum and minimum iterations.
for(i=0;i<3;i++)
{
d1[i]=MAX(err,fabs(der[i]));
d1[i]=fabs(der_old[i]-der[i])/d1[i];
der_old[i]=der[i];
}
d=MAX(MAX(d1[0],d1[1]),d1[2]);
if(n< minappx)
{
d=1;
}
if(n>= maxappx)
{
d=0;
}
del=0;
if(d> err)
{
del=1;
}
}
// Adjust results if I(x,p,q) = 1- I(1-x,q,p) was used
if (*x_in>*p_in/(*p_in+*q_in))
{
der[0]=1-der[0];
der[1]=-der[1];
der[2]=-der[2];
}
Free(c);
Free(an);
Free(bn);
Free(dan);
Free(dbn);
Free(dr);
Free(an1);
Free(an2);
Free(bn1);
Free(bn2);
Free(d1);
Free(der_old);
}
double F77_SUB(trigamm)(double *x)
{
return trigamma(*x);
}
