/Users/huttone/Devel/sedflux-new/sedflux/trunk/ew/utils/eh_num.c

Go to the documentation of this file.
00001 //---
00002 //
00003 // This file is part of sedflux.
00004 //
00005 // sedflux is free software; you can redistribute it and/or modify
00006 // it under the terms of the GNU General Public License as published by
00007 // the Free Software Foundation; either version 2 of the License, or
00008 // (at your option) any later version.
00009 //
00010 // sedflux is distributed in the hope that it will be useful,
00011 // but WITHOUT ANY WARRANTY; without even the implied warranty of
00012 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00013 // GNU General Public License for more details.
00014 //
00015 // You should have received a copy of the GNU General Public License
00016 // along with sedflux; if not, write to the Free Software
00017 // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
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 //   double EPS   = 3.0e-7;
00158 //   double FPMIN = 1.0e-30;
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 //   double EPS   = 3.0e-7;
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    // initialize y_new with NaN's.
00323    for ( j=0 ; j<len_new ; y_new[j]=bad_val , j++ );
00324 
00325    // Make sure the x values are monotonically increasing.
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       // set j to the first index inside of the given data.
00341       for ( j=0 ; x_new[j]<x[0] ; j++ );
00342 
00343       // interpolate linearly between points.
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 //   double TOL = 1e-5;
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 // NOTE: should this be nm=k ? Probably.  Used to be nm = k-1
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    // Exceptional cases.
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    // Central range.
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    // Near end points of range.
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    // The relative error of the approximation has absolute value less
01340    // than 8.9e-7.  One iteration of Halley's rational method (third
01341    // order) gives full machine precision.
01342    //
01343    // Newton's method: new x = x - f/f'
01344    // Halley's method: new x = x - 1/(f'/f - (f"/f')/2)
01345    // This function: f = erf(x) - y, f' = 2/sqrt(pi)*exp(-x^2), f" = -2*x*f'
01346    //---
01347 
01348    // Newton's correction.
01349    u = ( erf(x) - y ) / ( 2./sqrt(M_PI) * exp(-x*x));
01350 
01351    // Halley's step.
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    indx=ivector(1,m+1);
02539    a=matrix(1,m+1,1,m+1);
02540    b=vector(1,m+1);
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 //      mm=FMIN(ipj,2*m-ipj);
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 //      fft=vector(1,n<<1);
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 //      free_vector(fft,1,n<<1);
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 /* Compute a weighted average of the data in vector x, given the weights in vector f.
02745    Vectors are of length len.
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 //   return sqrt(-1);
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    // initialize y_bin with NaN's.
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    // define the edges of the data.
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       // Integrate the data in y over the entire bin.
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       // Find the lower j.
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       // Find the upper j.
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       // Integrate the data over these j.
02855 //      sum  = y[lower_j]*(left_bin-x_edge[lower_j])/(right_bin-left_bin);
02856 //      sum += y[upper_j]*(right_bin-x_edge[upper_j])/(right_bin-left_bin);
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 //#include "utils.h"
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 

Generated on Fri Jan 4 18:04:16 2008 for sedflux by  doxygen 1.5.2