=================================================================== RCS file: /home/cvs/OpenXM/src/hgm/mh/src/jack-n.c,v retrieving revision 1.39 retrieving revision 1.52 diff -u -p -r1.39 -r1.52 --- OpenXM/src/hgm/mh/src/jack-n.c 2016/02/04 02:52:19 1.39 +++ OpenXM/src/hgm/mh/src/jack-n.c 2016/06/06 04:39:30 1.52 @@ -4,8 +4,10 @@ #include #include #include "sfile.h" + +#define VSTRING "%!version2.0" /* - $OpenXM: OpenXM/src/hgm/mh/src/jack-n.c,v 1.38 2016/02/01 07:05:25 takayama Exp $ + $OpenXM: OpenXM/src/hgm/mh/src/jack-n.c,v 1.51 2016/06/04 07:53:08 takayama Exp $ Ref: copied from this11/misc-2011/A1/wishart/Prog jack-n.c, translated from mh.rr or tk_jack.rr in the asir-contrib. License: LGPL Koev-Edelman for higher order derivatives. @@ -15,6 +17,9 @@ 2. Use the recurrence to obtain beta(). 3. Easier input data file format for mh-n.c Changelog: + 2016.02.15 log of Ef + 2016.02.09 unify 2F1 and 1F1. Parser. + 2016.02.04 Ef_type (exponential or scalar factor type) 2016.02.01 ifdef C_2F1 ... 2016.01.12 2F1 2014.03.15 http://fe.math.kobe-u.ac.jp/Movies/oxvh/2014-03-11-jack-n-c-automatic see also hgm/doc/ref.html, @s/2014/03/15-my-note-jack-automatic-order-F_A-casta.pdf. @@ -48,6 +53,8 @@ static int Sample = Sample_default; static double *Iv2; static double Ef2; +static int SAR_warning = 1; + #ifdef NAN #else #define NAN 3.40282e+38 /* for old 32 bit machines. Todo, configure */ @@ -57,24 +64,14 @@ static double Ef2; #define M_n0 3 /* used for tests. Must be equal to M_n */ #define M_m_MAX 200 #define M_nmx M_m_MAX /* maximal of M_n */ -#ifdef C_2F1 -#define A_LEN 2 /* (a_1) , (a_1, ..., a_p)*/ -#define B_LEN 1 /* (b_1) */ -static int P_pFq=2; -static int Q_pFq=1; -#else -#define A_LEN 1 /* (a_1) , (a_1, ..., a_p)*/ -#define B_LEN 1 /* (b_1) */ -static int P_pFq=1; -static int Q_pFq=1; -#endif -static double A_pFq[A_LEN]; -static double B_pFq[B_LEN]; -#ifndef C_2F1 -static int Orig_1F1=1; -#else -static int Orig_1F1=0; -#endif + +static int A_LEN=-1; /* (a_1, ..., a_p), A_LEN=p */ +static int B_LEN=-1; /* (b_1,..., b_q), B_LEN=q */ +static double *A_pFq=NULL; +static double *B_pFq=NULL; +static int Ef_type=1; /* 1F1 for Wishart */ +/* Ef_type=2; 2F1, Hashiguchi note (1) */ + static int Debug = 0; static int Alpha = 2; /* 2 implies the zonal polynomial */ static int *Darray = NULL; @@ -194,7 +191,7 @@ static double jjk(int K[]); static double ppoch(double A,int K[]); static double ppoch2(double A,double B,int K[]); static double mypower(double x,int n); -static double qk(int K[],double A[A_LEN],double B[B_LEN]); +static double qk(int K[],double A[],double B[]); static int bb(int N[],int K[],int M[],int I,int J); static double beta(int K[],int M[]); static int printp(int kappa[]); @@ -224,10 +221,23 @@ static int setParamDefault(); static int next(struct SFILE *fp,char *s,char *msg); static int setParam(char *fname); static int showParam(struct SFILE *fp,int fd); +#ifdef STANDALONE +static int showParam_v1(struct SFILE *fp,int fd); +#endif static double iv_factor(void); static double gammam(double a,int n); static double mypower(double a,int n); +static double iv_factor_ef_type1(void); +static double iv_factor_ef_type2(void); +static double lgammam(double a,int n); +static double liv_factor_ef_type1(void); +static double liv_factor_ef_type2(void); + +static void setM_x(void); +static void setM_x_ef_type1(void); +static void setM_x_ef_type2(void); + #ifdef STANDALONE static int test_ptrans(); static int printp2(int kappa[]); @@ -242,13 +252,54 @@ static int mtest1b(); static double q3_5(double A[],double B[],int K[],int I); #endif -double mh_t(double A[A_LEN],double B[B_LEN],int N,int M); +double mh_t(double A[],double B[],int N,int M); double mh_t2(int J); struct MH_RESULT *jk_main(int argc,char *argv[]); struct MH_RESULT *jk_main2(int argc,char *argv[],int automode,double newX0g,int newDegree); int jk_freeWorkArea(); int jk_initializeWorkArea(); +static void setA(double a[],int alen); /* set A_LEN and A_pFq */ +static void setB(double b[],int blen); +static void setA(double a[],int alen) { + int i; + if (alen < 0) { + if (A_pFq != NULL) myfree(A_pFq); + A_pFq=NULL; A_LEN=-1; + return; + } + if (alen == 0) { + A_LEN=0; return; + } + A_LEN=alen; + A_pFq = (double *)mymalloc(A_LEN*sizeof(double)); + if (a != NULL) { + for (i=0; itest2.txt\n"); - oxprintfe(" ./hgm_w-n --idata test2.txt --gnuplotf test-g\n"); - oxprintfe(" gnuplot -persist s); + if (JK_byFile) oxprintfe("File %s is not found.\n",fname); mh_exit(-1); } - next(fp,s,"Mg(m)"); + /* set default initial values */ + Mg=-1; /* number of variables */ + Ng=(double *) mymalloc(sizeof(double)); *Ng=-1; /* *Ng is the degree of freedom 1F1 */ + X0g=0.1; /* evaluation point */ + Ef=1.0; /* exponential factor */ + Ef_type=1; + Hg=0.01; /* step size for RK */ + Dp = 1; /* sampling rate */ + Xng = 10.0; /* terminal point for RK */ + + /* Parser for the old style (version <2.0) input */ + version=next(fp,s,"Mg(m)"); + if (version == 2) goto myparse; sscanf(s,"%d",&Mg); rank = imypower(2,Mg); @@ -1793,7 +1815,6 @@ static int setParam(char *fname) { sscanf(s,"%lf",&(Beta[i])); } - Ng = (double *)mymalloc(sizeof(double)); next(fp,s,"%Ng= (freedom parameter n)"); sscanf(s,"%lf",Ng); @@ -1824,6 +1845,7 @@ static int setParam(char *fname) { sscanf(s,"%lf",&Xng); /* Reading the optional parameters */ + myparse: while ((tk = mh_getoken(s,SMAX-1,fp)).type != MH_TOKEN_EOF) { /* expect ID */ if (tk.type != MH_TOKEN_ID) { @@ -1891,15 +1913,14 @@ static int setParam(char *fname) { } // Format: #p_pFq=2 1.5 3.2 if (strcmp(s,"p_pFq")==0) { - Orig_1F1=0; if (mh_getoken(s,SMAX-1,fp).type != MH_TOKEN_EQ) { oxprintfe("Syntax error at %s\n",s); mh_exit(-1); } if ((tk=mh_getoken(s,SMAX-1,fp)).type != MH_TOKEN_INT) { oxprintfe("Syntax error at %s\n",s); mh_exit(-1); } - P_pFq = tk.ival; - for (i=0; i= 0)) { + if (A_LEN <1) setA(NULL,1); + if (B_LEN <1) setB(NULL,1); + A_pFq[0] = ((double)Mg+1.0)/2.0; + B_pFq[0] = ((double)Mg+1.0)/2.0 + ((double) (*Ng))/2.0; /* bug, double check */ + if (Debug) oxprintf("Calling mh_t with ([%lf],[%lf],%d,%d)\n",A_pFq[0],B_pFq[0],M_n,Mapprox); + } mh_fclose(fp); return(0); } - -static int showParam(struct SFILE *fp,int fd) { +#ifdef STANDALONE +/* may remove */ +static int showParam_v1(struct SFILE *fp,int fd) { int rank,i; char swork[1024]; if (fd) { @@ -1946,7 +2114,9 @@ static int showParam(struct SFILE *fp,int fd) { for (i=0; i= 0) { + sprintf(swork,"%%Ng=\n%lf\n",*Ng); mh_fputs(swork,fp); + } sprintf(swork,"%%X0g=\n%lf\n",X0g); mh_fputs(swork,fp); for (i=0; i= 0) { + sprintf(swork,"%%Ng=\n%lf\n",*Ng); mh_fputs(swork,fp); + } + sprintf(swork,"%%X0g=\n%lf\n",X0g); mh_fputs(swork,fp); + sprintf(swork,"%%Iv=\n"); mh_fputs(swork,fp); + for (i=0; i SERIES_ADMISSIBLE_RADIUS_TYPE1) { + if (SAR_warning) oxprintfe("Warning: evaluation point %lf for %d-th variable of the series 1F1 might be far from 0. Decrease q0 (or X0g for the standalone) if necessary.\n",M_x[i],i); + SAR_warning=0; + } + } +} +static void setM_x_ef_type2(void) { + int i; + for (i=0; i SERIES_ADMISSIBLE_RADIUS_TYPE2) { + if (SAR_warning) oxprintfe("Warning: evaluation point %lf for %d-th point of the series 2F1 is near 1. Decrease q0 (or X0g for the standalone).\n",M_x[i],i); + SAR_warning=0; + } + } +} +int reset_SAR_warning(int n) { + SAR_warning = n; + return(n); +} +/* log of gammam */ +static double lgammam(double a,int n) { + double v,v2; + int i; + v=log(M_PI)*n*(n-1)/2.0; /* log pi^(n*(n-1)/2) */ + v2=0; + for (i=1; i<=n; i++) { + v2 += lgamma(a-((double)(i-1))/2.0); /* not for big n */ + } + return(v+v2); +} + +/* log of iv_factor_ef_type1() */ +static double liv_factor_ef_type1(void) { + double v1; + double t; + double b; + double detSigma; + double c; + int i,n; + if (X0g<0){ myerror("Negative X0g\n"); mh_exit(-1);} + n = (int) (*Ng); + v1= log(X0g)*n*M_n/2.0; + t = 0.0; + for (i=0; i