00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021 #include <math.h>
00022 #include <eh_utils.h>
00023
00024 double
00025 eh_safe_dbl_division( double a , double b )
00026 {
00027 return ( b<1 && a>b*G_MAXDOUBLE ) ? G_MAXDOUBLE : ( ( (b>1 && a<b*G_MINDOUBLE) || a==0 ) ? 0 : a/b );
00028 }
00029
00030 gboolean
00031 eh_compare_dbl( double a , double b , double eps )
00032 {
00033 const gboolean STRONG = TRUE;
00034 double diff = fabs(a-b);
00035 double d1 = eh_safe_dbl_division( diff , fabs(a) );
00036 double d2 = eh_safe_dbl_division( diff , fabs(b) );
00037
00038 if ( STRONG ) return (d1<=eps && d2<=eps);
00039 else return (d1<=eps || d2<=eps);
00040 }
00041
00050 double eh_gamma_log( double xx )
00051 {
00052 double x,y,tmp,ser;
00053 static double cof[6]={76.18009172947146,-86.50532032941677,
00054 24.01409824083091,-1.231739572450155,
00055 0.1208650973866179e-2,-0.5395239384953e-5};
00056 gssize j;
00057
00058 y=x=xx;
00059 tmp=x+5.5;
00060 tmp -= (x+0.5)*log(tmp);
00061 ser=1.000000000190015;
00062 for (j=0;j<=5;j++) ser += cof[j]/++y;
00063 return -tmp+log(2.5066282746310005*ser/x);
00064 }
00065
00077 double eh_gamma_p( double a , double x )
00078 {
00079 double ans;
00080 double gamser,gammcf,gln;
00081
00082 eh_require( x>=0 );
00083 eh_require( a>=0 );
00084
00085 if (x < (a+1.0))
00086 {
00087 eh_gamma_series(&gamser,a,x,&gln);
00088 ans = gamser;
00089 } else {
00090 eh_gamma_cf(&gammcf,a,x,&gln);
00091 ans = 1.0-gammcf;
00092 }
00093 return ans;
00094 }
00095
00111 double eh_gamma_q( double a , double x )
00112 {
00113 double ans;
00114 double gamser,gammcf,gln;
00115
00116 eh_require( x >= 0 );
00117 eh_require( a >= 0 );
00118
00119 if ( x < (a+1.0) )
00120 {
00121 eh_gamma_series(&gamser,a,x,&gln);
00122 ans = 1.0-gamser;
00123 }
00124 else
00125 {
00126 eh_gamma_cf(&gammcf,a,x,&gln);
00127 ans = gammcf;
00128 }
00129
00130 return ans;
00131 }
00132
00153 void eh_gamma_cf( double* gammcf , double a , double x , double* gln )
00154 {
00155 gssize i;
00156 double an,b,c,d,del,h;
00157
00158
00159 double EPS = 1e-12;
00160 double FPMIN = G_MINDOUBLE;
00161 gint ITMAX = 100;
00162
00163 if ( x<a+1 )
00164 eh_warning( "This function should be used for x>a+1." );
00165
00166 *gln=eh_gamma_log(a);
00167 b=x+1.0-a;
00168 c=1.0/FPMIN;
00169 d=1.0/b;
00170 h=d;
00171 for ( i=0 ; i<ITMAX ; i++ )
00172 {
00173 an = -(i+1)*((i+1)-a);
00174 b += 2.0;
00175 d=an*d+b;
00176 if (fabs(d) < FPMIN) d=FPMIN;
00177 c=b+an/c;
00178 if (fabs(c) < FPMIN) c=FPMIN;
00179 d=1.0/d;
00180 del=d*c;
00181 h *= del;
00182 if (fabs(del-1.0) < EPS) break;
00183 }
00184 if (i >= ITMAX) eh_warning("a (%f) too large, ITMAX (%d) too small in gamma_cf" , a , ITMAX );
00185 *gammcf=exp(-x+a*log(x)-(*gln))*h;
00186 }
00187
00202 void eh_gamma_series( double* gamser , double a , double x , double* gln )
00203 {
00204 gssize n;
00205 double sum,del,ap;
00206
00207 double EPS = 1e-12;
00208 gint ITMAX = 100;
00209
00210 if ( x>a+1 )
00211 eh_warning( "This function should be used for x<a+1." );
00212
00213 eh_require( x>=0 );
00214
00215 *gln=eh_gamma_log(a);
00216 if ( eh_compare_dbl( x , 0 , 1e-12 ) )
00217 {
00218 *gamser=0.0;
00219 }
00220 else
00221 {
00222 ap=a;
00223 del=sum=1.0/a;
00224 for (n=0;n<ITMAX;n++)
00225 {
00226 ++ap;
00227 del *= x/ap;
00228 sum += del;
00229 if (fabs(del) < fabs(sum)*EPS) {
00230 *gamser=sum*exp(-x+a*log(x)-(*gln));
00231 return;
00232 }
00233 }
00234 eh_error("a too large, ITMAX too small in routine gamma_series: %f, %d." , a , ITMAX );
00235 }
00236
00237 return;
00238 }
00239
00248 double eh_factorial( gssize n )
00249 {
00250 static gssize ntop=4;
00251 static double a[33]={1.0,1.0,2.0,6.0,24.0};
00252 gssize j;
00253
00254 eh_return_val_if_fail( n>=0 , eh_nan() );
00255
00256 if (n > 32)
00257 return exp(eh_gamma_log(n+1.0));
00258
00259 while (ntop<n) {
00260 j=ntop++;
00261 a[ntop]=a[j]*ntop;
00262 }
00263
00264 return a[n];
00265 }
00266
00275 double eh_factorial_log( gssize n )
00276 {
00277 static double a[101];
00278
00279 eh_require( n>=0 );
00280
00281 if (n <= 1)
00282 return 0.0;
00283 if (n <= 100)
00284 return a[n] ? a[n] : (a[n]=eh_gamma_log(n+1.0));
00285 else
00286 return eh_gamma_log(n+1.0);
00287 }
00288
00304 double eh_binomial_coef( gssize n , gssize y )
00305 {
00306 return floor( .5+exp( eh_factorial_log(n) - eh_factorial_log(y) - eh_factorial_log(n-y) ) );
00307 }
00308
00309 void interpolate( double *x , double *y , gssize len ,
00310 double *x_new , double *y_new , gssize len_new )
00311 {
00312 interpolate_bad_val( x , y , len , x_new , y_new , len_new , eh_nan() );
00313 }
00314
00315 void interpolate_bad_val( double *x , double *y , gssize len ,
00316 double *x_new , double *y_new , gssize len_new ,
00317 double bad_val )
00318 {
00319 gint i,j;
00320 double m, b, x0;
00321
00322
00323 for ( j=0 ; j<len_new ; y_new[j]=bad_val , j++ );
00324
00325
00326 for ( i=1 ; i<len ; i++ )
00327 {
00328 if ( x[i]<=x[i-1] )
00329 {
00330 eh_error( "x values must be monotonically increasing" );
00331 eh_require_not_reached();
00332 }
00333 }
00334
00335 if ( x_new[len_new-1]<x[0] || x_new[0]>x[len-1] )
00336 return;
00337
00338 if ( len>1 )
00339 {
00340
00341 for ( j=0 ; x_new[j]<x[0] ; j++ );
00342
00343
00344 for ( i=0 ; i<len-1 ; i++ )
00345 {
00346 m = (y[i+1]-y[i])/(x[i+1]-x[i]);
00347 b = y[i];
00348 x0 = x[i];
00349 while ( j<len_new && x_new[j] <= x[i+1] )
00350 {
00351 y_new[j] = m*(x_new[j]-x0)+b;
00352 j++;
00353 }
00354 }
00355 }
00356 else
00357 {
00358 for ( i=0 ; i<len_new ; i++ )
00359 if ( x[0] == x_new[i] )
00360 y_new[i] = y[0];
00361 }
00362
00363 eh_message( "DONE" );
00364
00365 return;
00366 }
00367
00368 double poly_interpolate( double* xa , double* ya , gssize n , double x , double* dy )
00369 {
00370 double y;
00371 double err;
00372 int i,m,ns=1;
00373 double den,dif,dift,ho,hp,w;
00374 double *c,*d;
00375
00376 eh_require( xa );
00377 eh_require( ya );
00378
00379 dif=fabs(x-xa[0]);
00380 c = eh_new( double , n );
00381 d = eh_new( double , n );
00382 for (i=0;i<n;i++)
00383 {
00384 if ( (dift=fabs(x-xa[i])) < dif)
00385 {
00386 ns=i;
00387 dif=dift;
00388 }
00389 c[i]=ya[i];
00390 d[i]=ya[i];
00391 }
00392 y=ya[ns--];
00393 for ( m=1 ; m<n ; m++ )
00394 {
00395 for (i=0;i<n-m;i++)
00396 {
00397 ho=xa[i]-x;
00398 hp=xa[i+m]-x;
00399 w=c[i+1]-d[i];
00400 if ( (den=ho-hp) == 0.0)
00401 eh_error("Error in routine polint");
00402 den=w/den;
00403 d[i]=hp*den;
00404 c[i]=ho*den;
00405 }
00406 y += (err=(2*ns < (n-m-1) ? c[ns+1] : d[ns--]));
00407 }
00408
00409 if ( dy )
00410 *dy = err;
00411
00412 eh_free( d );
00413 eh_free( c );
00414
00415 return y;
00416 }
00417
00418 void poly_basis_funcs( double x , double* p , gssize n )
00419 {
00420 gssize i;
00421
00422 p[0] = 1.;
00423 for ( i=1 ; i<n ; i++ )
00424 p[i] = p[i-1]*x;
00425
00426 return;
00427 }
00428
00429 double* eh_poly_fit( double* x , double* y , gssize len , gssize n )
00430 {
00431 double* poly = NULL;
00432
00433 if ( len > n )
00434 {
00435 double chisq;
00436 double** u = eh_new_2( double , len , n+1 );
00437 double** v = eh_new_2( double , len , n+1 );
00438 double* w = eh_new ( double , n+1 );
00439 double* sig = eh_new ( double , len );
00440
00441 poly = eh_new( double , n+1 );
00442
00443 {
00444 gssize i;
00445 for ( i=0 ; i<len ; i++ )
00446 sig[i] = 1.;
00447 }
00448
00449 eh_svdfit(x,y,sig,len,poly,n+1,u,v,w,&chisq,poly_basis_funcs);
00450
00451 eh_free ( sig );
00452 eh_free ( w );
00453 eh_free_2( v );
00454 eh_free_2( u );
00455 }
00456
00457 return poly;
00458 }
00459
00460 double eh_poly_r_squared( double* x , double* y , gssize len , double* p , gssize n )
00461 {
00462 double ssr = 0;
00463 double sse = 0;
00464 double y_hat, y_bar;
00465 gssize i;
00466
00467 y_bar = eh_dbl_array_mean( y , len );
00468
00469 for ( i=0 ; i<len ; i++ )
00470 {
00471 y_hat = eh_poly_eval( x[i] , p , n );
00472 ssr += pow( y_hat - y_bar , 2 );
00473 sse += pow( y_hat - y[i] , 2 );
00474 }
00475
00476 return 1. - sse / ( ssr+sse );
00477 }
00478
00479 double eh_r_squared( double* x , double* y , gssize len , Eh_dbl_func_with_data f , gpointer data )
00480 {
00481 double ssr = 0;
00482 double sse = 0;
00483 double y_hat, y_bar;
00484 gssize i;
00485
00486 y_bar = eh_dbl_array_mean( y , len );
00487
00488 for ( i=0 ; i<len ; i++ )
00489 {
00490 y_hat = f( x[i] , data );
00491 ssr += pow( y_hat - y_bar , 2 );
00492 sse += pow( y_hat - y[i] , 2 );
00493 }
00494
00495 return 1. - sse / ( ssr+sse );
00496 }
00497
00498 void eh_svdfit( double* x , double* y , double* sig , gssize ndata ,
00499 double* a , gssize ma , double** u , double** v , double* w , double* chisq ,
00500 Eh_poly_basis_func funcs )
00501 {
00502 gssize j,i;
00503 double wmax,tmp,thresh,sum,*b,*afunc;
00504
00505 double TOL = 1e-12;
00506
00507 b = eh_new( double , ndata );
00508 afunc = eh_new( double , ma );
00509
00510 for ( i=0 ; i<ndata ; i++ )
00511 {
00512 (*funcs)( x[i] , afunc , ma );
00513 tmp=1.0/sig[i];
00514 for ( j=0; j<ma ; j++ ) u[i][j]=afunc[j]*tmp;
00515 b[i]=y[i]*tmp;
00516 }
00517
00518 eh_svdcmp(u,ndata,ma,w,v);
00519
00520 wmax=0.0;
00521 for ( j=0 ; j<ma ; j++ )
00522 if ( w[j] > wmax) wmax=w[j];
00523 thresh=TOL*wmax;
00524 for ( j=0 ; j<ma ; j++ )
00525 if (w[j] < thresh) w[j]=0.0;
00526
00527 eh_svbksb(u,w,v,ndata,ma,b,a);
00528
00529 *chisq=0.0;
00530 for ( i=0 ; i<ndata ; i++ )
00531 {
00532 (*funcs)(x[i],afunc,ma);
00533 for (sum=0.0,j=0;j<ma;j++) sum += a[j]*afunc[j];
00534 *chisq += (tmp=(y[i]-sum)/sig[i],tmp*tmp);
00535 }
00536 eh_free( afunc );
00537 eh_free( b );
00538 }
00539
00540 double eh_pythag( double a , double b )
00541 {
00542 double absa = fabs(a);
00543 double absb = fabs(b);
00544
00545 if (absa > absb)
00546 return absa*sqrt(1.0+eh_sqr(absb/absa));
00547 else
00548 return (absb == 0.0 ? 0.0 : absb*sqrt(1.0+eh_sqr(absa/absb)));
00549 }
00550
00551 void eh_svbksb( double** u , double* w , double** v , gssize m , gssize n ,double* b , double* x )
00552 {
00553 gssize jj,j,i;
00554 double s,*tmp;
00555
00556 tmp = eh_new( double , n );
00557 for (j=0;j<n;j++)
00558 {
00559 s=0.0;
00560 if (w[j]) {
00561 for (i=0;i<m;i++) s += u[i][j]*b[i];
00562 s /= w[j];
00563 }
00564 tmp[j]=s;
00565 }
00566 for (j=0;j<n;j++)
00567 {
00568 s=0.0;
00569 for (jj=0;jj<n;jj++) s += v[j][jj]*tmp[jj];
00570 x[j]=s;
00571 }
00572 eh_free( tmp );
00573 }
00574
00575 void eh_svdcmp( double** a , gssize m , gssize n , double* w , double** v )
00576 {
00577 int flag,i,its,j,jj,k,l,nm;
00578 double anorm,c,f,g,h,s,scale,x,y,z,*rv1;
00579
00580 rv1 = eh_new( double , n );
00581 g=scale=anorm=0.0;
00582 for (i=0;i<n;i++) {
00583 l=i+1;
00584 rv1[i]=scale*g;
00585 g=s=scale=0.0;
00586 if (i <= m) {
00587 for (k=i;k<m;k++) scale += fabs(a[k][i]);
00588 if (scale) {
00589 for (k=i;k<m;k++) {
00590 a[k][i] /= scale;
00591 s += a[k][i]*a[k][i];
00592 }
00593 f=a[i][i];
00594 g = -eh_nrsign(sqrt(s),f);
00595 h=f*g-s;
00596 a[i][i]=f-g;
00597 for (j=l;j<n;j++) {
00598 for (s=0.0,k=i;k<m;k++) s += a[k][i]*a[k][j];
00599 f=s/h;
00600 for (k=i;k<m;k++) a[k][j] += f*a[k][i];
00601 }
00602 for (k=i;k<m;k++) a[k][i] *= scale;
00603 }
00604 }
00605 w[i]=scale *g;
00606 g=s=scale=0.0;
00607 if (i <= m && i != n) {
00608 for (k=l;k<n;k++) scale += fabs(a[i][k]);
00609 if (scale) {
00610 for (k=l;k<n;k++) {
00611 a[i][k] /= scale;
00612 s += a[i][k]*a[i][k];
00613 }
00614 f=a[i][l];
00615 g = -eh_nrsign(sqrt(s),f);
00616 h=f*g-s;
00617 a[i][l]=f-g;
00618 for (k=l;k<n;k++) rv1[k]=a[i][k]/h;
00619 for (j=l;j<m;j++) {
00620 for (s=0.0,k=l;k<n;k++) s += a[j][k]*a[i][k];
00621 for (k=l;k<n;k++) a[j][k] += s*rv1[k];
00622 }
00623 for (k=l;k<n;k++) a[i][k] *= scale;
00624 }
00625 }
00626 anorm=eh_max(anorm,(fabs(w[i])+fabs(rv1[i])));
00627 }
00628 for (i=n-1;i>=0;i--) {
00629 if (i < n) {
00630 if (g) {
00631 for (j=l;j<n;j++)
00632 v[j][i]=(a[i][j]/a[i][l])/g;
00633 for (j=l;j<n;j++) {
00634 for (s=0.0,k=l;k<n;k++) s += a[i][k]*v[k][j];
00635 for (k=l;k<n;k++) v[k][j] += s*v[k][i];
00636 }
00637 }
00638 for (j=l;j<n;j++) v[i][j]=v[j][i]=0.0;
00639 }
00640 v[i][i]=1.0;
00641 g=rv1[i];
00642 l=i;
00643 }
00644 for (i=eh_min(m,n)-1;i>=0;i--) {
00645 l=i+1;
00646 g=w[i];
00647 for (j=l;j<n;j++) a[i][j]=0.0;
00648 if (g) {
00649 g=1.0/g;
00650 for (j=l;j<n;j++) {
00651 for (s=0.0,k=l;k<m;k++) s += a[k][i]*a[k][j];
00652 f=(s/a[i][i])*g;
00653 for (k=i;k<m;k++) a[k][j] += f*a[k][i];
00654 }
00655 for (j=i;j<m;j++) a[j][i] *= g;
00656 } else for (j=i;j<m;j++) a[j][i]=0.0;
00657 ++a[i][i];
00658 }
00659 for (k=n-1;k>=0;k--) {
00660 for (its=0;its<30;its++) {
00661 flag=1;
00662 for (l=k;l>=0;l--) {
00663 nm=l-1;
00664 if ((double)(fabs(rv1[l])+anorm) == anorm) {
00665 flag=0;
00666 break;
00667 }
00668 if ((double)(fabs(w[nm])+anorm) == anorm) break;
00669 }
00670 if (flag) {
00671 c=0.0;
00672 s=1.0;
00673 for (i=l;i<k;i++) {
00674 f=s*rv1[i];
00675 rv1[i]=c*rv1[i];
00676 if ((double)(fabs(f)+anorm) == anorm) break;
00677 g=w[i];
00678 h=eh_pythag(f,g);
00679 w[i]=h;
00680 h=1.0/h;
00681 c=g*h;
00682 s = -f*h;
00683 for (j=0;j<m;j++) {
00684 y=a[j][nm];
00685 z=a[j][i];
00686 a[j][nm]=y*c+z*s;
00687 a[j][i]=z*c-y*s;
00688 }
00689 }
00690 }
00691 z=w[k];
00692 if (l == k) {
00693 if (z < 0.0) {
00694 w[k] = -z;
00695 for (j=0;j<n;j++) v[j][k] = -v[j][k];
00696 }
00697 break;
00698 }
00699 if (its == 30) eh_error("no convergence in 30 svdcmp iterations");
00700 x=w[l];
00701
00702 nm=k;
00703
00704 y=w[nm];
00705 g=rv1[nm];
00706 h=rv1[k];
00707 f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
00708 g=eh_pythag(f,1.0);
00709 f=((x-z)*(x+z)+h*((y/(f+eh_nrsign(g,f)))-h))/x;
00710 c=s=1.0;
00711 for (j=l;j<nm;j++) {
00712 i=j+1;
00713 g=rv1[i];
00714 y=w[i];
00715 h=s*g;
00716 g=c*g;
00717 z=eh_pythag(f,h);
00718 rv1[j]=z;
00719 c=f/z;
00720 s=h/z;
00721 f=x*c+g*s;
00722 g = g*c-x*s;
00723 h=y*s;
00724 y *= c;
00725 for (jj=0;jj<n;jj++) {
00726 x=v[jj][j];
00727 z=v[jj][i];
00728 v[jj][j]=x*c+z*s;
00729 v[jj][i]=z*c-x*s;
00730 }
00731 z=eh_pythag(f,h);
00732 w[j]=z;
00733 if (z) {
00734 z=1.0/z;
00735 c=f*z;
00736 s=h*z;
00737 }
00738 f=c*g+s*y;
00739 x=c*y-s*g;
00740 for (jj=0;jj<m;jj++) {
00741 y=a[jj][j];
00742 z=a[jj][i];
00743 a[jj][j]=y*c+z*s;
00744 a[jj][i]=z*c-y*s;
00745 }
00746 }
00747 rv1[l]=0.0;
00748 rv1[k]=f;
00749 w[k]=x;
00750 }
00751 }
00752 eh_free( rv1 );
00753 }
00754
00755 double eh_poly_eval( double x , double* p , gssize n )
00756 {
00757 double val = 0.;
00758 gssize i;
00759
00760 for ( i=n ; i>0 ; i-- )
00761 val = (val + p[i])*x;
00762 val += p[0];
00763
00764 return val;
00765 }
00766
00767 double* eh_linear_fit( double* x , double* y , gssize len )
00768 {
00769 double* poly = NULL;
00770
00771 eh_return_val_if_fail( x , NULL );
00772 eh_return_val_if_fail( y , NULL );
00773
00774 if ( len>1 )
00775 {
00776 double sig_a, sig_b, chi_2, q;
00777 poly = eh_new( double , 2 );
00778
00779 eh_fit( x , y , len , NULL , FALSE , poly , poly+1 , &sig_a , &sig_b , &chi_2 , &q );
00780 }
00781
00782 return poly;
00783 }
00784
00785 void eh_fit( double* x , double* y , gssize len , double* sig , gboolean mwt ,
00786 double* a , double* b , double* siga , double* sigb , double* chi2 , double* q )
00787 {
00788 gssize i;
00789 double wt,t,sxoss,sx=0.0,sy=0.0,st2=0.0,ss,sigdat;
00790
00791 *b=0.0;
00792 if ( mwt )
00793 {
00794 ss=0.0;
00795 for ( i=0 ; i<len ; i++ )
00796 {
00797 wt=1.0/eh_sqr(sig[i]);
00798 ss += wt;
00799 sx += x[i]*wt;
00800 sy += y[i]*wt;
00801 }
00802 }
00803 else
00804 {
00805 for ( i=0 ; i<len ; i++ )
00806 {
00807 sx += x[i];
00808 sy += y[i];
00809 }
00810 ss=len;
00811 }
00812 sxoss=sx/ss;
00813 if ( mwt )
00814 {
00815 for ( i=0 ; i<len ; i++ )
00816 {
00817 t=(x[i]-sxoss)/sig[i];
00818 st2 += t*t;
00819 *b += t*y[i]/sig[i];
00820 }
00821 }
00822 else
00823 {
00824 for ( i=0 ; i<len ; i++ )
00825 {
00826 t=x[i]-sxoss;
00827 st2 += t*t;
00828 *b += t*y[i];
00829 }
00830 }
00831 *b /= st2;
00832 *a=(sy-sx*(*b))/ss;
00833 *siga=sqrt((1.0+sx*sx/(ss*st2))/ss);
00834 *sigb=sqrt(1.0/st2);
00835 *chi2=0.0;
00836 if ( !mwt )
00837 {
00838 for ( i=0 ; i<len ; i++ )
00839 *chi2 += eh_sqr(y[i]-(*a)-(*b)*x[i]);
00840 *q=1.0;
00841 sigdat=sqrt((*chi2)/(len-2));
00842 *siga *= sigdat;
00843 *sigb *= sigdat;
00844 }
00845 else
00846 {
00847 for ( i=0 ; i<len ; i++ )
00848 *chi2 += eh_sqr((y[i]-(*a)-(*b)*x[i])/sig[i]);
00849 *q=eh_gamma_q(0.5*(len-2),0.5*(*chi2));
00850 }
00851
00852 return;
00853 }
00854
00855 double trapzd( Eh_dbl_func_with_data func , double a , double b , gssize n , gpointer data )
00856 {
00857 double x,tnm,sum,del;
00858 static double s;
00859 gssize it,j;
00860
00861 if (n == 1)
00862 {
00863 return (s=0.5*(b-a)*( func(a,data)+func(b,data) ));
00864 }
00865 else
00866 {
00867 for (it=1,j=1;j<n-1;j++) it <<= 1;
00868
00869 tnm=it;
00870 del=(b-a)/tnm;
00871 x=a+0.5*del;
00872 for (sum=0.0,j=1;j<=it;j++,x+=del) sum += func(x,data);
00873 s=0.5*(s+(b-a)*sum/tnm);
00874 return s;
00875 }
00876 }
00877
00878 #define EH_QTRAP_EPS 1.0e-5
00879 #define EH_QTRAP_JMAX 20
00880
00881 double qtrap( Eh_dbl_func_with_data func , double a , double b , gpointer data )
00882 {
00883 gssize j;
00884 double s, olds;
00885
00886 olds = -1.0e30;
00887 for ( j=0 ; j<EH_QTRAP_JMAX ; j++ )
00888 {
00889 s = trapzd( func , a , b , j , data );
00890 if ( fabs(s-olds) < EH_QTRAP_EPS*fabs(olds) )
00891 return s;
00892 olds = s;
00893 }
00894 eh_error( "Too many steps in routine qtrap" );
00895 return 0.0;
00896 }
00897
00898 #define EH_QROMB_EPS 1.0e-3
00899 #define EH_QROMB_JMAX 20
00900 #define EH_QROMB_JMAXP (EH_QROMB_JMAX+1)
00901 #define EH_QROMB_K 5
00902
00903 double eh_integrate( Eh_dbl_func_with_data func , double a , double b )
00904 {
00905 return eh_integrate_with_data( func , a , b , NULL );
00906 }
00907
00908 double eh_integrate_with_data( Eh_dbl_func_with_data func , double a , double b , gpointer data )
00909 {
00910 double ss,dss;
00911 double s[EH_QROMB_JMAXP+1],h[EH_QROMB_JMAXP+1];
00912 gssize j;
00913
00914 h[0]=1.0;
00915 for (j=0;j<EH_QROMB_JMAX;j++)
00916 {
00917 s[j]=trapzd(func,a,b,j,data);
00918 if (j >= EH_QROMB_K)
00919 {
00920 ss = poly_interpolate(&h[j-EH_QROMB_K],&s[j-EH_QROMB_K],EH_QROMB_K,0.0,&dss);
00921 if (fabs(dss) < EH_QROMB_EPS*fabs(ss))
00922 return ss;
00923 }
00924 s[j+1]=s[j];
00925 h[j+1]=0.25*h[j];
00926 }
00927 eh_error("Too many steps in routine integrate");
00928 return 0.0;
00929 }
00930
00937 gboolean eh_is_even( gssize n )
00938 {
00939 return !(n%2);
00940 }
00941
00949 double eh_round( double val , double rnd )
00950 {
00951 if ( !eh_compare_dbl( val , 0 , 1e-12 ) )
00952 return ((int)(val/rnd+(val>0?1:-1)*.5))*rnd;
00953 else
00954 return 0.;
00955 }
00956
00963 double eh_reduce_angle( double angle )
00964 {
00965 return angle - 2*M_PI*floor(( angle + M_PI )/(2*M_PI));
00966 }
00967
00990 double*
00991 tridiag( double *l , double *d , double *u , double *b , double *x , int n )
00992 {
00993 if ( !eh_compare_dbl( d[0] , 0. , 1e-12 ) )
00994 {
00995 gint i;
00996 double beta = d[0];
00997 double* gamma = eh_new( double , n );
00998
00999 x[0] = b[0]/d[0];
01000
01001 for ( i=1 ; i<n ; i++ )
01002 {
01003 gamma[i] = u[i-1]/beta;
01004 beta = d[i] - l[i]*gamma[i];
01005 if ( beta == 0.0 )
01006 {
01007 eh_free( gamma );
01008 return NULL;
01009 }
01010 x[i] = (b[i]-l[i]*x[i-1])/beta;
01011 }
01012
01013 for ( i=n-2 ; i>=0 ; i-- )
01014 x[i] -= gamma[i+1]*x[i+1];
01015
01016 eh_free( gamma );
01017 }
01018 else
01019 x = NULL;
01020
01021 return x;
01022 }
01023
01024 #include "complex.h"
01025
01026 Complex *c_tridiag( Complex *l , Complex *d , Complex *u , Complex *b , Complex *x , int n )
01027 {
01028 int i;
01029 Complex beta, *gamma;
01030
01031 gamma = eh_new( Complex , n );
01032
01033 if ( c_abs(d[0]) == 0.0 )
01034 return NULL;
01035
01036 x[0] = c_div(b[0],d[0]);
01037 beta = d[0];
01038
01039 for ( i=1 ; i<n ; i++ )
01040 {
01041 gamma[i] = c_div(u[i-1],beta);
01042 beta = c_sub( d[i] , c_mul(l[i],gamma[i]) );
01043 if ( c_abs(beta) == 0.0 )
01044 return NULL;
01045 x[i] = c_div( c_sub(b[i],c_mul(l[i],x[i-1])) , beta );
01046 }
01047
01048 for ( i=n-2 ; i>=0 ; i-- )
01049 {
01050 x[i] = c_sub( x[i] , c_mul(gamma[i+1],x[i+1]) );
01051 }
01052
01053 eh_free( gamma );
01054
01055 return u;
01056 }
01057
01058 #include <math.h>
01059
01060 #define MAXIT 100
01061
01062 double rtsafe(void (*funcd)(double, double *, double *, double *), double x1, double x2, double xacc, double *data )
01063 {
01064 int j;
01065 double df,dx,dxold,f,fh,fl;
01066 double temp,xh,xl,rts;
01067
01068 (*funcd)(x1,&fl,&df,data);
01069 (*funcd)(x2,&fh,&df,data);
01070 if ((fl > 0.0 && fh > 0.0) || (fl < 0.0 && fh < 0.0))
01071 {
01072 eh_warning( "Root must be bracketed in rtsafe" );
01073 return eh_nan();
01074 }
01075 if (fl == 0.0) return x1;
01076 if (fh == 0.0) return x2;
01077 if (fl < 0.0) {
01078 xl=x1;
01079 xh=x2;
01080 } else {
01081 xh=x1;
01082 xl=x2;
01083 }
01084 rts=0.5*(x1+x2);
01085 dxold=fabs(x2-x1);
01086 dx=dxold;
01087 (*funcd)(rts,&f,&df,data);
01088 for (j=1;j<=MAXIT;j++) {
01089 if ((((rts-xh)*df-f)*((rts-xl)*df-f) >= 0.0)
01090 || (fabs(2.0*f) > fabs(dxold*df))) {
01091 dxold=dx;
01092 dx=0.5*(xh-xl);
01093 rts=xl+dx;
01094 if (xl == rts) return rts;
01095 } else {
01096 dxold=dx;
01097 dx=f/df;
01098 temp=rts;
01099 rts -= dx;
01100 if (temp == rts) return rts;
01101 }
01102 if (fabs(dx) < xacc) return rts;
01103 (*funcd)(rts,&f,&df,data);
01104 if (f < 0.0)
01105 xl=rts;
01106 else
01107 xh=rts;
01108 }
01109 eh_warning( "Maximum number of iterations exceeded in rtsafe" );
01110 return eh_nan();
01111 }
01112 #undef MAXIT
01113
01114 void nrerror(char error_text[])
01115 {
01116 fprintf( stderr , "%s\n" , error_text );
01117 eh_exit(-1);
01118 }
01119
01120 double eh_bisection( Eh_root_fcn f , double x_0 , double x_1 , double eps , gpointer user_data )
01121 {
01122 double f_0, f_1, f_mid;
01123 double x_mid, dx;
01124 double rtb;
01125 int i;
01126
01127 f_0 = (*f)( x_0 , user_data );
01128 f_1 = (*f)( x_1 , user_data );
01129
01130 eh_return_val_if_fail( f_0*f_1<0 , eh_nan() );
01131
01132 rtb = (f_0<0)?(dx=x_1-x_0,x_0):(dx=x_0-x_1,x_1);
01133
01134 for ( i=0 ; i<40 ; i++ )
01135 {
01136 dx *= .5;
01137 x_mid = rtb + dx;
01138 f_mid = (*f)( x_mid , user_data );
01139
01140 if ( f_mid<=0 )
01141 rtb = x_mid;
01142 if ( fabs(dx)<eps || f_mid==0. )
01143 return rtb;
01144 }
01145
01146 eh_return_val_if_fail( FALSE , eh_nan() );
01147 }
01148
01149 #define MAXIT 3000
01150
01151 double *anneal( double *x , int n , Cost_fcn *f , double cost_min )
01152 {
01153 double cost_before, cost_after;
01154 int i, j;
01155 int itr=0, max_itr=MAXIT;
01156
01157 do
01158 {
01159
01160 cost_before = (*f)( x , n );
01161
01162 i = eh_get_fuzzy_int( 0 , n-1 );
01163 do
01164 {
01165 j = eh_get_fuzzy_int( 0 , n-1 );
01166 }
01167 while ( j==i );
01168
01169 swap_dbl_vec( x , i , j );
01170
01171 cost_after = (*f)( x , n );
01172
01173 if ( cost_after>cost_before )
01174 swap_dbl_vec( x , i , j );
01175
01176 }
01177 while ( cost_after>cost_min && ++itr<max_itr );
01178
01179 return x;
01180 }
01181
01182 #undef MAXIT
01183
01184 double bessel_i_0( double x )
01185 {
01186 double ax,ans;
01187 double y;
01188
01189 if ((ax=fabs(x)) < 3.75)
01190 {
01191 y=x/3.75;
01192 y*=y;
01193 ans=1.0+y*(3.5156229+y*(3.0899424+y*(1.2067492
01194 +y*(0.2659732+y*(0.360768e-1+y*0.45813e-2)))));
01195 }
01196 else
01197 {
01198 y=3.75/ax;
01199 ans=(exp(ax)/sqrt(ax))*(0.39894228+y*(0.1328592e-1
01200 +y*(0.225319e-2+y*(-0.157565e-2+y*(0.916281e-2
01201 +y*(-0.2057706e-1+y*(0.2635537e-1+y*(-0.1647633e-1
01202 +y*0.392377e-2))))))));
01203 }
01204
01205 return ans;
01206 }
01207
01208 double bessel_k_0( double x )
01209 {
01210 double y,ans;
01211
01212 if (x <= 2.0) {
01213 y=x*x/4.0;
01214 ans=(-log(x/2.0)*bessel_i_0(x))+(-0.57721566+y*(0.42278420
01215 +y*(0.23069756+y*(0.3488590e-1+y*(0.262698e-2
01216 +y*(0.10750e-3+y*0.74e-5))))));
01217 } else {
01218 y=2.0/x;
01219 ans=(exp(-x)/sqrt(x))*(1.25331414+y*(-0.7832358e-1
01220 +y*(0.2189568e-1+y*(-0.1062446e-1+y*(0.587872e-2
01221 +y*(-0.251540e-2+y*0.53208e-3))))));
01222 }
01223
01224 return ans;
01225 }
01226
01227 void zbesk_( double* , double* , double* , long int* , long int* , double* , double* , long int* , long int* );
01228
01229 double eh_kei_0( double x )
01230 {
01231 double n=0;
01232 long int n_mem=1;
01233 long int kode=1;
01234 long int n_err=0;
01235 long int err=0;
01236 double z[2];
01237 double ans[2];
01238
01239 eh_require( x>=0 );
01240
01241 z[0] = x*cos(M_PI/4.);
01242 z[1] = x*sin(M_PI/4.);
01243
01244 if ( z[0]<1e-5 && z[1]<1e-5 )
01245 ans[1] = -M_PI/4.;
01246 else
01247 zbesk_( &(z[0]) , &(z[1]) , &n , &kode , &n_mem ,
01248 &(ans[0]) , &(ans[1]) , &n_err , &err );
01249
01250 if ( err )
01251 {
01252 switch ( err )
01253 {
01254 case 1:
01255 eh_message( "Illegal arguments." );
01256 break;
01257 case 2:
01258 eh_message( "Overflow." );
01259 break;
01260 case 3:
01261 eh_message( "Some loss of accuracy in argument reduction." );
01262 break;
01263 case 4:
01264 eh_message( "Complete loss of accuracy, z or nu too large." );
01265 break;
01266 case 5:
01267 eh_message( "No convergence." );
01268 break;
01269 default:
01270 eh_error( "Illegal error flag." );
01271 }
01272 }
01273
01274 return ans[1];
01275 }
01276
01277 #include <math.h>
01278
01290 double eh_erf_inv( double y )
01291 {
01292 double x;
01293 double y_0, z, u;
01294 static double a[4] =
01295 { 0.886226899 , -1.645349621 , 0.914624893 , -0.140543331 };
01296 static double b[4] =
01297 { -2.118377725 , 1.442710462 , -0.329097515 , 0.012229801 };
01298 static double c[4] =
01299 { -1.970840454 , -1.624906493 , 3.429567803 , 1.641345311 };
01300 static double d[2] =
01301 { 3.543889200 , 1.637067800 };
01302
01303
01304 if ( y == -1 )
01305 return -1./0.;
01306 if ( y == 1 )
01307 return +1./0.;
01308 if ( fabs(y) > 1 )
01309 return eh_nan();
01310 if ( eh_isnan(y) )
01311 return eh_nan();
01312
01313
01314 y_0 = .7;
01315 if ( fabs(y) < y_0 )
01316 {
01317 z = pow(y,2);
01318 x = y
01319 * ( ( (a[3]*z + a[2])*z + a[1])*z + a[0])
01320 / ( ( ( (b[3]*z + b[2])*z + b[1])*z + b[0])*z + 1. );
01321 }
01322
01323
01324 else if ( y_0<y && y<1 )
01325 {
01326 z = sqrt( -log((1.-y)/2.) );
01327 x = (((c[3]*z+c[2])*z+c[1])*z+c[0])
01328 / ((d[1]*z+d[0])*z+1);
01329 }
01330
01331 else if ( -y_0>y && y>-1 )
01332 {
01333 z = sqrt( -log((1.+y)/2.) );
01334 x = -(((c[3]*z+c[2])*z+c[1])*z+c[0])
01335 / ((d[1]*z+d[0])*z+1);
01336 }
01337
01338
01339
01340
01341
01342
01343
01344
01345
01346
01347
01348
01349 u = ( erf(x) - y ) / ( 2./sqrt(M_PI) * exp(-x*x));
01350
01351
01352 x = x - u / (1+x*u);
01353
01354 return x;
01355 }
01356
01357 long int i1mach_( long int *i )
01358 {
01359 switch (*i)
01360 {
01361 case 9:
01362 return G_MAXLONG;
01363 case 14:
01364 return 53;
01365 case 15:
01366 return -1021;
01367 case 16:
01368 return 1024;
01369 default:
01370 eh_require_not_reached();
01371 return G_MINLONG;
01372 }
01373
01374 }
01375
01376 double d1mach_( long int *i )
01377 {
01378 switch ( *i )
01379 {
01380 case 1:
01381 return G_MINDOUBLE;
01382 case 2:
01383 return G_MAXDOUBLE;
01384 case 4:
01385 return pow(2,1-53);
01386 case 5:
01387 return 0.30102999566398;
01388 default:
01389 eh_require_not_reached();
01390 return eh_nan();
01391 }
01392 }
01393
01394 #if defined( ENABLE_BLAS )
01395 #include <cblas.h>
01396 #endif
01397
01398 double* eh_dbl_array_new( gssize n )
01399 {
01400 double* x = NULL;
01401
01402 if ( n>0 )
01403 x = eh_new( double , n );
01404
01405 return x;
01406 }
01407
01408 double* eh_dbl_array_new_set( gssize n , double val )
01409 {
01410 double* x = NULL;
01411
01412 if ( n>0 )
01413 {
01414 gssize i;
01415 x = eh_new( double , n );
01416 for ( i=0 ; i<n ; i++ )
01417 x[i] = val;
01418 }
01419
01420 return x;
01421 }
01422
01423 double*
01424 eh_dbl_array_dup( double* s , gssize n )
01425 {
01426 return eh_dbl_array_copy( NULL , s , n );
01427 }
01428
01429 double*
01430 eh_dbl_array_copy( double* d , double* s , gssize n )
01431 {
01432 if ( s )
01433 {
01434 if ( !d )
01435 d = eh_dbl_array_new( n );
01436
01437 g_memmove( d , s , sizeof(double)*n );
01438 }
01439
01440 return d;
01441 }
01442
01443 double*
01444 eh_dbl_col_to_array( double* d , double* col , gint n , gssize offset )
01445 {
01446 if ( col )
01447 {
01448 gint i;
01449
01450 if ( !d )
01451 d = eh_dbl_array_new( n );
01452
01453 for ( i=0 ; i<n ; i++ )
01454 d[i] = col[i*offset];
01455 }
01456 return d;
01457 }
01458
01459 double*
01460 eh_dbl_array_to_col( double* d , double* s , gint n , gssize offset )
01461 {
01462 if ( s )
01463 {
01464 gint i;
01465
01466 if ( !d )
01467 d = eh_new( double , n*offset );
01468
01469 for ( i=0 ; i<n ; i++ )
01470 d[i*offset] = s[i];
01471
01472 }
01473 return d;
01474 }
01475
01476 gint
01477 eh_dbl_array_rebin_len( double* s , gssize n , double bin_size )
01478 {
01479 gint len = 0;
01480
01481 if ( s )
01482 len = ceil ( n / bin_size );
01483
01484 return len;
01485 }
01486
01487 double*
01488 eh_dbl_array_rebin_smaller( double* s , gssize n , double bin_size , gint* d_len )
01489 {
01490 double* d = NULL;
01491
01492 eh_require( bin_size<=1. );
01493
01494 if ( eh_compare_dbl( bin_size , 1. , 1e-12 ) )
01495 {
01496 d = eh_dbl_array_dup( s , n );
01497 if ( d_len )
01498 *d_len = n;
01499 }
01500 else if ( s )
01501 {
01502 gint len = ceil ( n / bin_size );
01503 gint top_i = floor( n / bin_size );
01504 gint i, j;
01505 double x;
01506 double f;
01507
01508 d = eh_new( double , len );
01509
01510 f = 1.-bin_size;
01511 d[0] = bin_size*s[0];
01512 for ( i=1,x=bin_size ; i<top_i ; i++,x+=bin_size )
01513 {
01514 j = (gint)(x+bin_size);
01515 d[i] = s[j-1]*f + s[j]*(bin_size-f);
01516 f = 1. - (bin_size-f);
01517 f = f - (gint)f;
01518 }
01519
01520 if ( len!=top_i )
01521 {
01522 d[i] = s[n-1]*f;
01523 }
01524
01525 if ( d_len )
01526 *d_len = len;
01527 }
01528
01529 return d;
01530 }
01531
01532 double*
01533 eh_dbl_array_rebin_larger( double* s , gssize n , double bin_size , gint* d_len )
01534 {
01535 double* d = NULL;
01536
01537 eh_require( bin_size>=1. );
01538
01539 if ( eh_compare_dbl( bin_size , 1. , 1e-12 ) )
01540 {
01541 d = eh_dbl_array_dup( s , n );
01542 if ( d_len )
01543 *d_len = n;
01544 }
01545 else if ( s )
01546 {
01547 gint len = ceil ( n / bin_size );
01548 gint top_i = floor( n / bin_size );
01549 gint i;
01550 double x;
01551
01552 d = eh_new( double , len );
01553
01554 for ( i=0,x=0 ; i<top_i ; i++,x+=bin_size )
01555 {
01556 d[i] = eh_dbl_array_sum( s+(gint)x , (gint)(x+bin_size - (gint)x ) );
01557 d[i] -= (x - (gint)(x) )*s[(gint)(x) ];
01558 d[i] += (x+bin_size - (gint)(x+bin_size))*s[(gint)(x+bin_size)];
01559 }
01560
01561 if ( len!=top_i )
01562 {
01563 gint n_bins = n - (gint)x;
01564
01565 d[i] = eh_dbl_array_sum( s+(gint)x , n_bins );
01566 d[i] -= (x - (gint)(x) )*s[(gint)(x) ];
01567 }
01568
01569 if ( d_len )
01570 *d_len = len;
01571 }
01572
01573 return d;
01574 }
01575
01576 double*
01577 eh_dbl_array_rebin( double* s , gssize n , double bin_size , gint* d_len )
01578 {
01579 double* d = NULL;
01580
01581 if ( bin_size<1. )
01582 d = eh_dbl_array_rebin_smaller( s , n , bin_size , d_len );
01583 else
01584 d = eh_dbl_array_rebin_larger ( s , n , bin_size , d_len );
01585
01586 return d;
01587 }
01588
01589 gssize eh_dbl_array_min_ind( const double* x , gssize n )
01590 {
01591 gssize ind = -1;
01592
01593 eh_require( x )
01594 {
01595 double min = G_MAXDOUBLE;
01596 gssize i;
01597 for ( i=0 ; i<n ; i++ )
01598 if ( x[i]<min )
01599 {
01600 min = x[i];
01601 ind = i;
01602 }
01603 }
01604 return ind;
01605 }
01606
01607 double eh_dbl_array_min( const double* x , gsize n )
01608 {
01609 double min = G_MAXDOUBLE;
01610
01611 eh_require( x )
01612 {
01613 gssize i;
01614 for ( i=0 ; i<n ; i++ )
01615 if ( x[i]<min )
01616 min = x[i];
01617 }
01618 return min;
01619 }
01620
01621 gssize eh_dbl_array_max_ind( const double* x , gssize n )
01622 {
01623 gssize ind = -1;
01624
01625 eh_require( x )
01626
01627 {
01628 double max = -G_MAXDOUBLE;
01629 gssize i;
01630 for ( i=0 ; i<n ; i++ )
01631 if ( x[i]>max )
01632 {
01633 max = x[i];
01634 ind = i;
01635 }
01636 }
01637
01638 return ind;
01639 }
01640
01641 double eh_dbl_array_max( const double* x , gsize n )
01642 {
01643 double max = -G_MAXDOUBLE;
01644
01645 eh_require( x )
01646
01647 {
01648 gssize i;
01649 for ( i=0 ; i<n ; i++ )
01650 if ( x[i]>max )
01651 max = x[i];
01652 }
01653
01654 return max;
01655 }
01656
01657 double eh_dbl_array_abs_max( const double* x , gsize n )
01658 {
01659 double max = -G_MAXDOUBLE;
01660
01661 eh_require( x )
01662
01663 #if !defined( ENABLE_BLAS )
01664 {
01665 gssize i;
01666 double val;
01667 for ( i=0 ; i<n ; i++ )
01668 {
01669 val = fabs( x[i] );
01670 if ( val>max )
01671 max = val;
01672 }
01673 }
01674 #else
01675 {
01676 gssize i = cblas_idamax( n , x , 1 );
01677 max = x[i];
01678 }
01679 #endif
01680 return max;
01681 }
01682
01683 gssize
01684 eh_dbl_array_fprint( FILE* fp , double* x , gssize n )
01685 {
01686 gssize total_bytes = 0;
01687
01688 eh_require( x );
01689 eh_require( fp );
01690
01691 {
01692 gssize i, top_i=n-1;
01693 for ( i=0 ; i<top_i ; i++ )
01694 total_bytes += fprintf( fp , "%f " , x[i] );
01695 total_bytes = fprintf( fp , "%f\n" , x[i] );
01696 }
01697
01698 return total_bytes;
01699 }
01700
01701 gint
01702 eh_dbl_array_write( FILE *fp , double *x , gint len )
01703 {
01704 size_t s=0;
01705
01706 eh_require( fp );
01707 eh_require( x );
01708
01709 if ( fp && x )
01710 {
01711 gint n_i = len;
01712 gint n, i, i_0;
01713 gint el_size = sizeof(double);
01714 gint one = 1, size;
01715 gdouble this_val;
01716
01717 for ( i_0=0 ; i_0<n_i ; i_0+=n )
01718 {
01719 if ( i_0==n_i-1 || x[i_0] == x[i_0+1] )
01720 {
01721 this_val = x[i_0];
01722
01723 for ( i=i_0,n=0 ;
01724 i<n_i && x[i]==this_val ;
01725 i++,n++ );
01726
01727 s += fwrite( &el_size , sizeof(int) , 1 , fp )*sizeof(int);
01728 s += fwrite( &n , sizeof(int) , 1 , fp )*sizeof(int);
01729 s += fwrite( &this_val , el_size , 1 , fp )*el_size;
01730 }
01731 else
01732 {
01733 for ( i=i_0+1,n=1 ;
01734 i<n_i && x[i-1]!=x[i] ;
01735 i++,n++ );
01736
01737 if ( i<n_i )
01738 n--;
01739
01740 size = n*el_size;
01741
01742 s += fwrite( &size , sizeof(int) , 1 , fp )*sizeof(int);
01743 s += fwrite( &one , sizeof(int) , 1 , fp )*sizeof(int);
01744 s += fwrite( &(x[i_0]) , size , 1 , fp )*size;
01745 }
01746 }
01747 }
01748
01749 return s;
01750 }
01751
01752 double eh_dbl_array_mean( const double *x , gsize n )
01753 {
01754 return eh_dbl_array_sum( x , n )/(double)n;
01755 }
01756
01757 double* eh_dbl_array_normalize( double* x , gsize n )
01758 {
01759 eh_require( x )
01760 {
01761 double sum = eh_dbl_array_sum( x , n );
01762 if ( fabs(sum)>1e-12 )
01763 eh_dbl_array_mult( x , n , 1./sum );
01764 }
01765 return x;
01766 }
01767
01768 double* eh_dbl_array_foreach( double* x , gssize n , Eh_dbl_func f )
01769 {
01770 eh_require( x );
01771 eh_require( n>0 );
01772
01773 {
01774 gssize i;
01775 for ( i=0 ; i<n ; i++ )
01776 x[i] = f(x[i]);
01777 }
01778
01779 return x;
01780 }
01781
01782 double* eh_dbl_array_add_scalar( double* x , gssize n , double a )
01783 {
01784 eh_require( x );
01785 eh_require( n>0 );
01786
01787 {
01788 gssize i;
01789 for ( i=0 ; i<n ; i++ )
01790 x[i] += a;
01791 }
01792
01793 return x;
01794 }
01795
01796 double*
01797 eh_dbl_array_add_each( double* d , gssize n , double* s )
01798 {
01799 eh_require( d );
01800 eh_require( s );
01801
01802 #if !defined( ENABLE_BLAS )
01803 if ( d && s )
01804 {
01805 gint i;
01806 for ( i=0 ; i<n ; i++ )
01807 d[i] += s[i];
01808 }
01809 #else
01810 cblas_daxpy( n , 1. , s , 1 , d , 1 );
01811 #endif
01812 return d;
01813 }
01814
01815 double* eh_dbl_array_add( double* dest , double* src , gssize n )
01816 {
01817 eh_require( dest );
01818 eh_require( src );
01819
01820 #if !defined( ENABLE_BLAS )
01821 {
01822 gssize i;
01823 for ( i=0 ; i<n ; i++ )
01824 dest[i] += src[i];
01825 }
01826 #else
01827 cblas_daxpy( n , 1. , src , 1 , dest , 1 );
01828 #endif
01829
01830 return dest;
01831 }
01832
01833 double* eh_dbl_array_mult( double* x , gsize n , double a )
01834 {
01835 eh_require( x );
01836 #if !defined( ENABLE_BLAS )
01837 {
01838 gssize i;
01839 for ( i=0 ; i<n ; i++ )
01840 x[i] *= a;
01841 }
01842 #else
01843 cblas_dscal( n , a , x , 1 );
01844 #endif
01845 return x;
01846 }
01847
01848 double*
01849 eh_dbl_array_mult_each( double* x , gssize n , double* y )
01850 {
01851 eh_require( x );
01852 eh_require( y );
01853
01854 if ( x && y )
01855 {
01856 gssize i;
01857 for ( i=0 ; i<n ; i++ )
01858 x[i] *= y[i];
01859 }
01860 return x;
01861 }
01862
01863 double eh_dbl_array_var( const double* x , gsize n )
01864 {
01865 double var = eh_nan();
01866
01867 eh_require( x )
01868 {
01869 gssize i;
01870 double m = eh_dbl_array_mean( x , n );
01871 for ( var=0,i=0 ; i<n ; i++ )
01872 var += pow( x[i] - m , 2. );
01873 var /= (double)n;
01874 }
01875
01876 return var;
01877 }
01878
01879 double
01880 eh_dbl_array_sum( const double *x , gsize n )
01881 {
01882 double sum=0;
01883
01884 eh_return_val_if_fail( n>0 , eh_nan() );
01885 eh_return_val_if_fail( x , eh_nan() );
01886
01887 {
01888 gssize i;
01889 for ( i=0 ; i<n ; i++ )
01890 sum += x[i];
01891 }
01892
01893 return sum;
01894 }
01895
01896 double eh_dbl_array_abs_sum( const double *x , gsize n )
01897 {
01898 double sum=0;
01899
01900 eh_return_val_if_fail( n>0 , eh_nan() );
01901 eh_return_val_if_fail( x , eh_nan() );
01902
01903 #if !defined( ENABLE_BLAS )
01904 {
01905 gssize i;
01906 for ( i=0 ; i<n ; i++ )
01907 sum += fabs(x[i]);
01908 }
01909 #else
01910 sum = cblas_dasum( n , x , 1 );
01911 #endif
01912 return sum;
01913 }
01914
01915 void eh_dbl_array_fabs( double* x , gsize n )
01916 {
01917 eh_require( x );
01918 eh_require( n>0 );
01919 if ( x && n>0 )
01920 {
01921 gsize i;
01922 for ( i=0 ; i<n ; i++ )
01923 x[i] = fabs(x[i]);
01924 }
01925 }
01926
01927 double *eh_dbl_array_diff( double *d , const double *x , gsize len , gssize n )
01928 {
01929 eh_return_val_if_fail( x , NULL );
01930 eh_return_val_if_fail( len>0 , NULL );
01931
01932 eh_require( n>=0 );
01933
01934 if ( !d )
01935 d = eh_new0( double , len );
01936
01937 if ( n>0 )
01938 {
01939 gssize i, j;
01940 double* c = eh_new( double , n+1 );
01941
01942 for ( j=0 ; j<=n ; j++ )
01943 c[j] = eh_binomial_coef(n,j);
01944
01945 if ( eh_is_even( n ) )
01946 {
01947 gssize k = n/2;
01948 gssize top_i = len-k-1;
01949
01950 for ( i=k ; i<=top_i ; i++ )
01951 {
01952 for ( j=0 ; j<=n ; j+=2 )
01953 d[i] += c[j]*x[i+k-j];
01954
01955 for ( j=1 ; j<=n ; j+=2 )
01956 d[i] -= c[j]*x[i+k-j];
01957 }
01958
01959 for ( i=0 ; i<k ; i++ )
01960 d[i] = d[k];
01961 for ( i=top_i+1 ; i<len ; i++ )
01962 d[i] = d[top_i];
01963
01964 }
01965 else
01966 {
01967 gssize k = (n-1)/2;
01968 gssize top_i = len-k-2;
01969
01970 for ( i=k ; i<=top_i ; i++ )
01971 {
01972 for ( j=0,d[i]=0 ; j<=n ; j+=2 )
01973 d[i] += c[j]*x[i+k+1-j];
01974
01975 for ( j=1 ; j<=n ; j+=2 )
01976 d[i] -= c[j]*x[i+k+1-j];
01977 }
01978
01979 for ( i=0 ; i<k ; i++ )
01980 d[i] = d[k];
01981 for ( i=top_i+1 ; i<len ; i++ )
01982 d[i] = d[top_i];
01983 }
01984
01985 eh_free( c );
01986 }
01987 else
01988 g_memmove( d , x , sizeof(double)*len );
01989
01990 return d;
01991 }
01992
01993 double* eh_dbl_array_gradient( const double *y , gsize n , double dx )
01994 {
01995 eh_require( y );
01996 eh_require( n>1 );
01997 eh_require( dx>0 );
01998
01999 if ( n>1 )
02000 {
02001 double* dy_dx = eh_new( double , n );
02002 double two_dx = 2.*dx;
02003 gsize top_n = n-1;
02004 gsize i;
02005
02006 for ( i=1 ; i<top_n ; i++ )
02007 dy_dx[i] = (y[i+1]-y[i-1]) / two_dx;
02008 dy_dx[0] = (y[1]-y[0])/dx;
02009 dy_dx[top_n] = (y[top_n]-y[top_n-1])/dx;
02010
02011 return dy_dx;
02012 }
02013 else
02014 return NULL;
02015
02016 }
02017
02018 double*
02019 eh_dbl_array_set( double *x , gsize n , double set_val )
02020 {
02021 gsize i;
02022
02023 if ( !x ) x = eh_new( double , n );
02024
02025 for ( i=0 ; i<n ; i++ )
02026 x[i] = set_val;
02027
02028 return x;
02029 }
02030
02031 double *eh_dbl_array_grid( double *x , gsize n , double start , double dx )
02032 {
02033 gssize i;
02034
02035 for ( i=1,x[0]=start ; i<n ; i++ )
02036 x[i] = x[i-1]+dx;
02037
02038 return x;
02039 }
02040
02041 double* eh_dbl_array_running_mean( double* x , gssize len , gssize n_left , gssize n_right )
02042 {
02043 eh_require( n_left+n_right+1 <= len );
02044 eh_require( n_left>=0 );
02045 eh_require( n_right>=0 );
02046
02047 eh_return_val_if_fail( x!=NULL , NULL );
02048
02049 if ( n_left>0 || n_right>0 )
02050 {
02051 gint64 i;
02052 gint64 top_i = len - n_right;
02053 gint64 win_size = n_left + n_right + 1;
02054 double a = 1./win_size;
02055 double mean = 0;
02056
02057 eh_dbl_array_mult( x , len , a );
02058 mean = eh_dbl_array_sum( x , win_size );
02059
02060 x[n_left] = mean;
02061 for ( i=n_left+1 ; i<top_i ; i++ )
02062 {
02063 mean += x[i+n_right] - x[i-n_left];
02064 x[i] = mean;
02065 }
02066 }
02067
02068 return x;
02069 }
02070
02071
02072 double *eh_dbl_array_conv( double *x , gsize len_x , double *y , gsize len_y )
02073 {
02074 double *ans, *data, *resp;
02075 gulong n;
02076
02077 if ( len_x==0 || !x || len_y==0 || !y || len_y>len_x )
02078 return NULL;
02079
02080 n = len_x+len_y;
02081
02082 if ( g_bit_nth_msf(n,-1)!=g_bit_nth_lsf(n,-1) )
02083 n = 1<<( g_bit_nth_msf( n , -1 )+1 );
02084
02085 data = eh_new0( double , n );
02086 resp = eh_new0( double , n );
02087 ans = eh_new0( double , 2*n );
02088
02089 memcpy( data , x , sizeof(double)*len_x );
02090 memcpy( resp , y , sizeof(double)*len_y );
02091
02092 convlv( data-1 , n , resp-1 , len_y , 1 , ans-1 );
02093
02094 eh_free( data );
02095 eh_free( resp );
02096
02097 return ans;
02098 }
02099
02100 void savgol(double* c, gssize np , gssize nl , gssize nr , gssize ld , gssize m );
02101 void convlv(double data[], unsigned long n, double respns[], unsigned long m,
02102 int isign, double ans[]);
02103
02104 double* eh_low_pass_filter( double* x , gssize len )
02105 {
02106 gssize n_left = 2;
02107 gssize n_right = 2;
02108 gssize ld = 0;
02109 gssize m = 0;
02110 gssize np = 5;
02111 double* ans = eh_new0( double , 2*len );
02112 double* c = eh_new0( double , len );
02113
02114 savgol( c-1 , np , n_left , n_right , ld , m );
02115
02116 convlv( x-1 , len , c-1 , np , 1 , ans-1 );
02117
02118 eh_free( c );
02119
02120 return ans;
02121 }
02122
02123 double *eh_dbl_array_cum_mean_dir( double *x , gsize n , gboolean forward )
02124 {
02125 gssize i;
02126 double *mean;
02127 if ( n==0 || !x )
02128 return NULL;
02129 mean = eh_dbl_array_cum_sum_dir( x , n , forward );
02130 if ( forward )
02131 for ( i=1 ; i<n ; i++ )
02132 mean[i] = mean[i]/((double)i+1.);
02133 else
02134 for ( i=n-2 ; i>=0 ; i-- )
02135 mean[i] = mean[i]/((double)(n-i));
02136 return mean;
02137 }
02138
02139 double *eh_dbl_array_cum_sum_dir( double *x , gsize n , gboolean forward )
02140 {
02141 gssize i;
02142 double *sum;
02143
02144 if ( n==0 || !x )
02145 return NULL;
02146 sum = eh_new( double , n );
02147 if ( forward )
02148 for ( sum[0]=x[0],i=1 ; i<n ; i++ )
02149 sum[i] = sum[i-1]+x[i];
02150 else
02151 for ( sum[n-1]=x[n-1],i=n-2 ; i>=0 ; i-- )
02152 sum[i] = sum[i+1]+x[i];
02153 return sum;
02154 }
02155
02156 double *eh_dbl_array_cum_max_dir( double *x , gsize n , gboolean forward )
02157 {
02158 gssize i;
02159 double *max;
02160 if ( n==0 || !x )
02161 return NULL;
02162 max = eh_new( double , n );
02163 if ( forward )
02164 for ( max[0]=x[0],i=1 ; i<n ; i++ )
02165 max[i] = (x[i]>max[i-1])?x[i]:max[i-1];
02166 else
02167 for ( max[n-1]=x[n-1],i=n-2 ; i>=0 ; i-- )
02168 max[i] = (x[i]>max[i+1])?x[i]:max[i+1];
02169 return max;
02170 }
02171
02172 double *eh_dbl_array_cum_min_dir( double *x , gsize n , gboolean forward )
02173 {
02174 gssize i;
02175 double *min;
02176 if ( n==0 || !x )
02177 return NULL;
02178 min = eh_new( double , n );
02179 if ( forward )
02180 for ( min[0]=x[0],i=1 ; i<n ; i++ )
02181 min[i] = (x[i]<min[i-1])?x[i]:min[i-1];
02182 else
02183 for ( min[n-1]=x[n-1],i=n-2 ; n>=0 ; i-- )
02184 min[i] = (x[i]<min[i+1])?x[i]:min[i+1];
02185 return min;
02186 }
02187
02188 gboolean eh_dbl_array_compare( double *x , double *y , gssize len , double eps )
02189 {
02190 gboolean is_same = TRUE;
02191
02192 if ( x!=y && (x && y) )
02193 {
02194 gssize i;
02195 for ( i=0 ; i<len && !is_same ; i++ )
02196 if ( !eh_compare_dbl(x[i],y[i],eps) )
02197 is_same = FALSE;
02198 }
02199
02200 return is_same;
02201 }
02202
02203 gboolean
02204 eh_dbl_array_cmp_ge( double* x , double* y , gssize len )
02205 {
02206 gboolean is_ge = TRUE;
02207
02208 if ( x && y && ( x!=y ) )
02209 {
02210 gint i;
02211 for ( i=0 ; i<len && is_ge ; i++ )
02212 is_ge = is_ge && ( x[i] >= y[i] );
02213 }
02214 else
02215 is_ge = FALSE;
02216
02217 return is_ge;
02218 }
02219
02220 gboolean
02221 eh_dbl_array_each_ge( double val , double *x , gssize len )
02222 {
02223 gboolean is_ge = TRUE;
02224
02225 eh_return_val_if_fail( x , FALSE );
02226
02227 {
02228 gint i;
02229 for ( i=0 ; i<len && is_ge ; i++ )
02230 is_ge = is_ge && ( x[i] >= val );
02231 }
02232
02233 return is_ge;
02234 }
02235
02236 gboolean
02237 eh_dbl_array_each_le( double val , double *x , gssize len )
02238 {
02239 gboolean is_le = TRUE;
02240
02241 eh_return_val_if_fail( x , FALSE );
02242
02243 {
02244 gint i;
02245 for ( i=0 ; i<len && is_le ; i++ )
02246 is_le = is_le && ( x[i] <= val );
02247 }
02248
02249 return is_le;
02250 }
02251
02252 gboolean eh_dbl_array_is_monotonic_up( double *x , gsize n )
02253 {
02254 gssize i;
02255
02256 for ( i=1 ; i<n ; i++ )
02257 if ( x[i-1] >= x[i] )
02258 return FALSE;
02259
02260 return TRUE;
02261 }
02262
02263 gboolean eh_dbl_array_is_monotonic_down( double *x , gsize n )
02264 {
02265 gssize i;
02266
02267 for ( i=1 ; i<n ; i++ )
02268 if ( x[i-1] <= x[i] )
02269 return FALSE;
02270
02271 return TRUE;
02272 }
02273
02289 double *eh_linspace( double x1 , double x2 , gssize n )
02290 {
02291 double *x = NULL;
02292
02293 eh_require( !eh_compare_dbl(x1,x2,1e-12) );
02294 eh_require( n>1 );
02295
02296 {
02297 gssize i;
02298 double dx = fabs(x2-x1)/(n-1.);
02299 gssize sign = (x2>x1)?1:-1;
02300
02301 x = eh_new( double , n );
02302
02303 for ( i=1 , x[0]=x1 ; i<n ; i++ )
02304 x[i] = x[i-1] + sign*dx;
02305 }
02306
02307 return x;
02308 }
02309
02310 gssize*
02311 eh_id_array( gssize i_0 , gssize i_1 , gssize* n )
02312 {
02313 gssize* id = NULL;
02314
02315 eh_require( i_1>=i_0 );
02316
02317 if ( i_1>=i_0 )
02318 {
02319 gint i;
02320 gint len = i_1 - i_0 + 1;
02321
02322 id = eh_new( gssize , len+1 );
02323
02324 for ( i=0 ; i<len ; i++ )
02325 id[i] = i_0+i;
02326 id[len] = -1;
02327
02328 if ( n )
02329 *n = len;
02330 }
02331 else
02332 {
02333 if ( n )
02334 *n = 0;
02335 }
02336
02337 return id;
02338 }
02339
02340 double*
02341 eh_uniform_array( double x1 , double x2 , double dx , gint* n )
02342 {
02343 double* x = NULL;
02344
02345 eh_require( n );
02346 eh_require( x2>x1 );
02347 eh_require( dx>0 );
02348
02349 *n = ( x2-x1 )/dx;
02350
02351 if ( *n>0 )
02352 {
02353 gssize i, len=*n;
02354
02355 x = eh_new( double , len );
02356 for ( i=1,x[0]=x1 ; i<len ; i++ )
02357 x[i] = x[i-1] + dx;
02358
02359 }
02360 else
02361 *n = 0;
02362
02363 return x;
02364 }
02365
02366 double*
02367 eh_dbl_array_linspace( double* x , gssize n_x , double x_0 , double dx )
02368 {
02369 eh_require( x );
02370 eh_require( n_x>=0 );
02371
02372 eh_return_val_if_fail( x && n_x>=0 , NULL )
02373 {
02374 gssize i;
02375 for ( i=0 ; i<n_x ; i++ )
02376 x[i] = i*dx + x_0;
02377 return x;
02378 }
02379 }
02380
02388 gboolean eh_dbl_array_is_monotonic( double* x , gssize len )
02389 {
02390 gssize i;
02391
02392 eh_require( x );
02393 eh_require( len>0 );
02394
02395 if ( len==1 )
02396 return TRUE;
02397 else if ( x[1]>x[0] )
02398 {
02399 for ( i=2 ; i<len ; i++ )
02400 if ( x[i]<=x[i-1] )
02401 return FALSE;
02402 }
02403 else if ( x[1]<x[0] )
02404 {
02405 for ( i=2 ; i<len ; i++ )
02406 if ( x[i]<=x[i-1] )
02407 return FALSE;
02408 }
02409 else
02410 return FALSE;
02411
02412 return TRUE;
02413 }
02414
02429 double *eh_logspace( double d1 , double d2 , int n )
02430 {
02431 int i;
02432 double *x = eh_linspace( d1 , d2 , n );
02433 for ( i=0 ; i<n ; i++ )
02434 x[i] = pow( 10. , x[i] );
02435 return x;
02436 }
02437
02438 void lubksb( double** a , gssize n , gssize* indx , double* b )
02439 {
02440 gssize i,ii=0,ip,j;
02441 double sum;
02442
02443 for (i=1;i<=n;i++)
02444 {
02445 ip=indx[i];
02446 sum=b[ip];
02447 b[ip]=b[i];
02448 if (ii)
02449 for (j=ii;j<=i-1;j++) sum -= a[i][j]*b[j];
02450 else if (sum) ii=i;
02451 b[i]=sum;
02452 }
02453 for (i=n;i>=1;i--) {
02454 sum=b[i];
02455 for (j=i+1;j<=n;j++) sum -= a[i][j]*b[j];
02456 b[i]=sum/a[i][i];
02457 }
02458 }
02459
02460 #define TINY 1.0e-20;
02461
02462 void ludcmp( double** a , gssize n , gssize* indx , double* d )
02463 {
02464 gssize i,imax,j,k;
02465 double big,dum,sum,temp;
02466 double *vv;
02467
02468 vv = eh_new( double , n ) - 1;
02469 *d=1.0;
02470 for (i=1;i<=n;i++) {
02471 big=0.0;
02472 for (j=1;j<=n;j++)
02473 if ((temp=fabs(a[i][j])) > big) big=temp;
02474 if (big == 0.0) nrerror("Singular matrix in routine ludcmp");
02475 vv[i]=1.0/big;
02476 }
02477 for (j=1;j<=n;j++) {
02478 for (i=1;i<j;i++) {
02479 sum=a[i][j];
02480 for (k=1;k<i;k++) sum -= a[i][k]*a[k][j];
02481 a[i][j]=sum;
02482 }
02483 big=0.0;
02484 for (i=j;i<=n;i++) {
02485 sum=a[i][j];
02486 for (k=1;k<j;k++)
02487 sum -= a[i][k]*a[k][j];
02488 a[i][j]=sum;
02489 if ( (dum=vv[i]*fabs(sum)) >= big) {
02490 big=dum;
02491 imax=i;
02492 }
02493 }
02494 if (j != imax) {
02495 for (k=1;k<=n;k++) {
02496 dum=a[imax][k];
02497 a[imax][k]=a[j][k];
02498 a[j][k]=dum;
02499 }
02500 *d = -(*d);
02501 vv[imax]=vv[j];
02502 }
02503 indx[j]=imax;
02504 if (a[j][j] == 0.0) a[j][j]=TINY;
02505 if (j != n) {
02506 dum=1.0/(a[j][j]);
02507 for (i=j+1;i<=n;i++) a[i][j] *= dum;
02508 }
02509 }
02510 vv += 1;
02511 eh_free( vv );
02512 }
02513
02514 #undef TINY
02515
02516 void savgol(double* c, gssize np , gssize nl , gssize nr , gssize ld , gssize m )
02517 {
02518 void lubksb(),ludcmp();
02519 gssize imj,ipj,j,k,kk,mm,*indx;
02520 double d,fac,sum,**a,*b;
02521
02522 eh_require( np >= nl+nr+1 );
02523 eh_require( nl >= 0 );
02524 eh_require( nr >= 0 );
02525 eh_require( ld <= m );
02526 eh_require( nl+nr >= m );
02527
02528 indx = eh_new( gssize , m+1 ) - 1;
02529 a = eh_new_2( double , m+1 , m+1 );
02530 {
02531 gssize i;
02532 for ( i=0 ; i<m+1 ; i++ )
02533 a[i] -= 1;
02534 a -= 1;
02535 }
02536 b = eh_new( double , m+1 ) - 1;
02537
02538
02539
02540
02541
02542
02543 for (ipj=0;ipj<=(m << 1);ipj++) {
02544 sum=(ipj ? 0.0 : 1.0);
02545 for (k=1;k<=nr;k++) sum += pow((double)k,(double)ipj);
02546 for (k=1;k<=nl;k++) sum += pow((double)-k,(double)ipj);
02547
02548 mm=eh_min(ipj,2*m-ipj);
02549 for (imj = -mm;imj<=mm;imj+=2) a[1+(ipj+imj)/2][1+(ipj-imj)/2]=sum;
02550 }
02551 ludcmp(a,m+1,indx,&d);
02552 for (j=1;j<=m+1;j++) b[j]=0.0;
02553 b[ld+1]=1.0;
02554 lubksb(a,m+1,indx,b);
02555 for (kk=1;kk<=np;kk++) c[kk]=0.0;
02556 for (k = -nl;k<=nr;k++) {
02557 sum=b[1];
02558 fac=1.0;
02559 for (mm=1;mm<=m;mm++) sum += b[mm+1]*(fac *= k);
02560 kk=((np-k) % np)+1;
02561 c[kk]=sum;
02562 }
02563 b += 1;
02564 a += 1;
02565 a[0] += 1;
02566 indx += 1;
02567 eh_free(b);
02568 eh_free( a );
02569 eh_free(indx);
02570 }
02571
02572 double *vector( long l , long h );
02573 void free_vector( double *x , long l , long h );
02574
02575 void convlv(double data[], unsigned long n, double respns[], unsigned long m,
02576 int isign, double ans[])
02577 {
02578 void realft(double data[], unsigned long n, int isign);
02579 void twofft(double data1[], double data2[], double fft1[], double fft2[],
02580 unsigned long n);
02581 unsigned long i,no2;
02582 double dum,mag2,*fft;
02583
02584
02585 fft = eh_new( double , n<<1 ) - 1;
02586 for (i=1;i<=(m-1)/2;i++)
02587 respns[n+1-i]=respns[m+1-i];
02588 for (i=(m+3)/2;i<=n-(m-1)/2;i++)
02589 respns[i]=0.0;
02590 twofft(data,respns,fft,ans,n);
02591 no2=n>>1;
02592 for (i=2;i<=n+2;i+=2) {
02593 if (isign == 1) {
02594 ans[i-1]=(fft[i-1]*(dum=ans[i-1])-fft[i]*ans[i])/no2;
02595 ans[i]=(fft[i]*dum+fft[i-1]*ans[i])/no2;
02596 } else if (isign == -1) {
02597 if ((mag2=pow(ans[i-1],2.)+pow(ans[i],2.)) == 0.0)
02598 nrerror("Deconvolving at response zero in convlv");
02599 ans[i-1]=(fft[i-1]*(dum=ans[i-1])+fft[i]*ans[i])/mag2/no2;
02600 ans[i]=(fft[i]*dum-fft[i-1]*ans[i])/mag2/no2;
02601 } else nrerror("No meaning for isign in convlv");
02602 }
02603 ans[2]=ans[n+1];
02604 realft(ans,n,-1);
02605
02606 fft += 1;
02607 eh_free( fft );
02608 }
02609
02610 double *vector( long l , long h )
02611 {
02612 double *x;
02613 x = eh_new( double , h-l+1 );
02614 return x-l;
02615 }
02616
02617 void free_vector( double *x , long l , long h )
02618 {
02619 x += l;
02620 eh_free( x );
02621 }
02622
02623 void four1(double data[], unsigned long nn, int isign)
02624 {
02625 unsigned long n,mmax,m,j,istep,i;
02626 double wtemp,wr,wpr,wpi,wi,theta;
02627 double tempr,tempi;
02628
02629 n=nn << 1;
02630 j=1;
02631 for (i=1;i<n;i+=2) {
02632 if (j > i) {
02633 swap_dbl(data[j],data[i]);
02634 swap_dbl(data[j+1],data[i+1]);
02635 }
02636 m=n >> 1;
02637 while (m >= 2 && j > m) {
02638 j -= m;
02639 m >>= 1;
02640 }
02641 j += m;
02642 }
02643 mmax=2;
02644 while (n > mmax) {
02645 istep=mmax << 1;
02646 theta=isign*(6.28318530717959/mmax);
02647 wtemp=sin(0.5*theta);
02648 wpr = -2.0*wtemp*wtemp;
02649 wpi=sin(theta);
02650 wr=1.0;
02651 wi=0.0;
02652 for (m=1;m<mmax;m+=2) {
02653 for (i=m;i<=n;i+=istep) {
02654 j=i+mmax;
02655 tempr=wr*data[j]-wi*data[j+1];
02656 tempi=wr*data[j+1]+wi*data[j];
02657 data[j]=data[i]-tempr;
02658 data[j+1]=data[i+1]-tempi;
02659 data[i] += tempr;
02660 data[i+1] += tempi;
02661 }
02662 wr=(wtemp=wr)*wpr-wi*wpi+wr;
02663 wi=wi*wpr+wtemp*wpi+wi;
02664 }
02665 mmax=istep;
02666 }
02667 }
02668
02669 void realft(double data[], unsigned long n, int isign)
02670 {
02671 void four1(double data[], unsigned long nn, int isign);
02672 unsigned long i,i1,i2,i3,i4,np3;
02673 double c1=0.5,c2,h1r,h1i,h2r,h2i;
02674 double wr,wi,wpr,wpi,wtemp,theta;
02675
02676 theta=3.141592653589793/(double) (n>>1);
02677 if (isign == 1) {
02678 c2 = -0.5;
02679 four1(data,n>>1,1);
02680 } else {
02681 c2=0.5;
02682 theta = -theta;
02683 }
02684 wtemp=sin(0.5*theta);
02685 wpr = -2.0*wtemp*wtemp;
02686 wpi=sin(theta);
02687 wr=1.0+wpr;
02688 wi=wpi;
02689 np3=n+3;
02690 for (i=2;i<=(n>>2);i++) {
02691 i4=1+(i3=np3-(i2=1+(i1=i+i-1)));
02692 h1r=c1*(data[i1]+data[i3]);
02693 h1i=c1*(data[i2]-data[i4]);
02694 h2r = -c2*(data[i2]+data[i4]);
02695 h2i=c2*(data[i1]-data[i3]);
02696 data[i1]=h1r+wr*h2r-wi*h2i;
02697 data[i2]=h1i+wr*h2i+wi*h2r;
02698 data[i3]=h1r-wr*h2r+wi*h2i;
02699 data[i4] = -h1i+wr*h2i+wi*h2r;
02700 wr=(wtemp=wr)*wpr-wi*wpi+wr;
02701 wi=wi*wpr+wtemp*wpi+wi;
02702 }
02703 if (isign == 1) {
02704 data[1] = (h1r=data[1])+data[2];
02705 data[2] = h1r-data[2];
02706 } else {
02707 data[1]=c1*((h1r=data[1])+data[2]);
02708 data[2]=c1*(h1r-data[2]);
02709 four1(data,n>>1,-1);
02710 }
02711 }
02712
02713 void twofft(double data1[], double data2[], double fft1[], double fft2[],
02714 unsigned long n)
02715 {
02716 void four1(double data[], unsigned long nn, int isign);
02717 unsigned long nn3,nn2,jj,j;
02718 double rep,rem,aip,aim;
02719
02720 nn3=1+(nn2=2+n+n);
02721 for (j=1,jj=2;j<=n;j++,jj+=2) {
02722 fft1[jj-1]=data1[j];
02723 fft1[jj]=data2[j];
02724 }
02725 four1(fft1,n,1);
02726 fft2[1]=fft1[2];
02727 fft1[2]=fft2[2]=0.0;
02728 for (j=3;j<=n+1;j+=2) {
02729 rep=0.5*(fft1[j]+fft1[nn2-j]);
02730 rem=0.5*(fft1[j]-fft1[nn2-j]);
02731 aip=0.5*(fft1[j+1]+fft1[nn3-j]);
02732 aim=0.5*(fft1[j+1]-fft1[nn3-j]);
02733 fft1[j]=rep;
02734 fft1[j+1]=aim;
02735 fft1[nn2-j]=rep;
02736 fft1[nn3-j] = -aim;
02737 fft2[j]=aip;
02738 fft2[j+1] = -rem;
02739 fft2[nn2-j]=aip;
02740 fft2[nn3-j]=rem;
02741 }
02742 }
02743
02744
02745
02746
02747 double
02748 eh_dbl_array_mean_weighted( const double x[] , gint len , const double f[] )
02749 {
02750 gint i = 0;
02751 double sum = 0;
02752
02753 for ( ; i<len ; i++ )
02754 sum += f[i]*x[i];
02755
02756 return sum;
02757 }
02758
02759 #ifndef M_LN2
02760 # define M_LN2 0.69314718055994530942
02761 #endif
02762
02763 #ifndef HAVE_LOG2
02764 double
02765 log2(double x)
02766 {
02767 return log(x)/M_LN2;
02768 }
02769 #endif
02770
02771 #undef M_LN2
02772
02773 #if defined( OLD_EH_NAN )
02774
02775 float eh_nan(void)
02776 {
02777 gint32 a=0x7FF00000L;
02778 return *((float*)(&a));
02779 }
02780
02781 int eh_isnan(float x)
02782 {
02783 return ( ((*(gint32*)&(x) & 0x7F800000L) == 0x7F800000L)
02784 && ((*(gint32*)&(x) & 0x007FFFFFL) != 0x00000000L) );
02785 }
02786 #else
02787
02788 double eh_nan( void )
02789 {
02790
02791 return g_strtod( "NAN" , NULL );
02792 }
02793
02794 gboolean eh_isnan( double x )
02795 {
02796 return isnan(x);
02797 }
02798 #endif
02799
02800 void eh_rebin_dbl_array( double *x , double *y , gssize len ,
02801 double *x_bin , double *y_bin , gssize len_bin )
02802 {
02803 eh_rebin_dbl_array_bad_val( x , y , len ,
02804 x_bin , y_bin , len_bin ,
02805 eh_nan() );
02806 }
02807
02808 void eh_rebin_dbl_array_bad_val(
02809 double *x , double *y , gssize len ,
02810 double *x_bin , double *y_bin , gssize len_bin ,
02811 double bad_val )
02812 {
02813 gssize i, j;
02814 gssize top_i, top_j, lower_j, upper_j;
02815 double left_bin, right_bin, lower, upper, upper_bin, lower_bin;
02816 double sum;
02817 double *x_edge;
02818
02819
02820 for ( i=0 ; i<len_bin ; y_bin[i]=bad_val , i++ );
02821
02822 top_i = len_bin-1;
02823 top_j = len-1;
02824 lower_bin = x_bin[0] - ( x_bin[1] - x_bin[0] ) * .5;
02825 upper_bin = x_bin[top_i] + ( x_bin[top_i] - x_bin[top_i-1] ) * .5;
02826 lower = x[0] - ( x[1] - x[0] ) * .5;
02827 upper = x[top_j] + ( x[top_j] - x[top_j-1] ) * .5;
02828
02829
02830 x_edge = eh_new( double , len+1 );
02831 x_edge[0] = x[0] - ( x[1] - x[0] ) * .5;
02832 x_edge[len] = x[top_j] + ( x[top_j] - x[top_j-1] ) * .5;
02833 for ( j=1 ; j<len ; j++ )
02834 x_edge[j] = ( x[j-1] + x[j] ) * .5;
02835
02836 upper_j = 0;
02837 for ( i=0 ; i<len_bin && j<=len ; i++ )
02838 {
02839
02840
02841 left_bin = (i!=0) ?( x_bin[i] + x_bin[i-1] ) * .5 : lower_bin;
02842 right_bin = (i!=top_i)?( x_bin[i+1] + x_bin[i] ) * .5 : upper_bin;
02843
02844
02845 for ( j=upper_j ; j<=len && x_edge[j]<=left_bin ; j++ );
02846 lower_j = j-1;
02847 eh_clamp( lower_j , 0 , len );
02848
02849
02850 for ( j=lower_j ; j<=len && x_edge[j]<=right_bin ; j++ );
02851 upper_j = j;
02852 eh_clamp( upper_j , 0 , len );
02853
02854
02855
02856
02857
02858 sum = 0;
02859 if ( left_bin > x_edge[upper_j] || right_bin < x_edge[lower_j] )
02860 sum = bad_val;
02861 else if ( upper_j-lower_j>1 )
02862 {
02863 if ( left_bin >= x_edge[lower_j] )
02864 sum += y[lower_j]
02865 * (x_edge[lower_j+1]-left_bin);
02866 else
02867 sum += y[lower_j]
02868 * (x_edge[lower_j+1]-x_edge[lower_j]);
02869 if ( right_bin <= x_edge[upper_j] )
02870 sum += y[upper_j-1]
02871 * (right_bin-x_edge[upper_j-1]);
02872 else
02873 sum += y[upper_j-1]
02874 * (x_edge[upper_j]-x_edge[upper_j-1]);
02875 for ( j=lower_j+1 ; j<upper_j-1 ; j++ )
02876 sum += y[j]*(x_edge[j+1]-x_edge[j]);
02877 sum /= (right_bin-left_bin);
02878 }
02879 else
02880 for ( j=lower_j ; j<upper_j ; j++ )
02881 sum += y[j];
02882
02883
02884 y_bin[i] = sum;
02885 }
02886
02887 eh_free( x_edge );
02888
02889 return;
02890 }
02891
02892 #include <math.h>
02893
02894
02895 double*
02896 eh_dbl_array_diffuse_implicit( double* x , gint len , double c )
02897 {
02898 if ( x )
02899 {
02900 double* l = eh_new( double , len );
02901 double* d = eh_new( double , len );
02902 double* u = eh_new( double , len );
02903 double* b = eh_dbl_array_dup( x , len );
02904
02905 eh_dbl_array_set( l , len , -c );
02906 eh_dbl_array_set( d , len , 1.+2.*c );
02907 eh_dbl_array_set( u , len , -c );
02908 eh_dbl_array_set( x , len , 0. );
02909
02910 l[len-1] = -c;
02911 d[len-1] = 1+c;
02912 u[0] = -c;
02913 d[0] = 1+c;
02914
02915 tridiag( l , d , u , b , x , len );
02916
02917 eh_free( l );
02918 eh_free( d );
02919 eh_free( u );
02920 eh_free( b );
02921 }
02922 return x;
02923 }
02924
02925 double*
02926 eh_dbl_array_diffuse_explicit( double* x , gint len , double c )
02927 {
02928 if ( x )
02929 {
02930 gint i;
02931 double* x_new = eh_dbl_array_dup( x , len );
02932 const gint top_i = len-1;
02933
02934 for ( i=1 ; i<top_i ; i++ )
02935 x_new[i] += c * ( x[i-1] - 2.*x[i] + x[i+1] );
02936
02937 x_new[0] += c * ( -x[0] + x[1] );
02938 x_new[top_i] += c * ( -x[top_i] + x[top_i-1] );
02939
02940 eh_dbl_array_copy( x , x_new , len );
02941
02942 eh_free( x_new );
02943 }
02944
02945 return x;
02946 }
02947
02948 double*
02949 eh_dbl_array_diffuse( double* x , gint len , double c , Eh_num_method method )
02950 {
02951 switch ( method )
02952 {
02953 case EH_NUM_IMPLICIT: eh_dbl_array_diffuse_implicit( x , len , c ); break;
02954 case EH_NUM_EXPLICIT: eh_dbl_array_diffuse_explicit( x , len , c ); break;
02955 default: eh_require_not_reached();
02956 }
02957 return x;
02958 }
02959