=================================================================== RCS file: /home/cvs/OpenXM/src/hgm/mh/src/jack-n.c,v retrieving revision 1.11 retrieving revision 1.46 diff -u -p -r1.11 -r1.46 --- OpenXM/src/hgm/mh/src/jack-n.c 2013/03/05 05:26:07 1.11 +++ OpenXM/src/hgm/mh/src/jack-n.c 2016/02/15 06:02:39 1.46 @@ -4,21 +4,30 @@ #include #include #include "sfile.h" + +#define VSTRING "%!version2.0" /* -$OpenXM: OpenXM/src/hgm/mh/src/jack-n.c,v 1.10 2013/03/01 05:26:25 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. -cf. 20-my-note-mh-jack-n.pdf, /Movies/oxvh/priv-j1/2011-12-14-ke-mh-jack.mov -Todo: -1. Cash the transposes of partitions. -2. Use the recurrence to obtain beta(). -3. Easier input data file format for mh-n.c -Changelog: -2012.02.21, porting to OpenXM/src/hgm -2011.12.22, --table option, which is experimental. -2011.12.19, bug fix. jjk() should return double. It can become more than max int. -2011.12.15, mh.r --> jack-n.c + $OpenXM: OpenXM/src/hgm/mh/src/jack-n.c,v 1.45 2016/02/13 22:56:50 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. + cf. 20-my-note-mh-jack-n.pdf, /Movies/oxvh/priv-j1/2011-12-14-ke-mh-jack.mov + Todo: + 1. Cash the transposes of partitions. + 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. + 2014.03.14, --automatic option. Output estimation data. + 2012.02.21, porting to OpenXM/src/hgm + 2011.12.22, --table option, which is experimental. + 2011.12.19, bug fix. jjk() should return double. It can become more than max int. + 2011.12.15, mh.r --> jack-n.c */ /****** from mh-n.c *****/ @@ -53,8 +62,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 */ -#define A_LEN 1 /* (a_1) , (a_1, ..., a_p)*/ -#define B_LEN 1 /* (b_1) */ + +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; @@ -93,6 +108,70 @@ static double Xarray[M_nmx][M_m_MAX]; static double *M_qk=NULL; /* saves pochhammerb */ static double M_rel_error=0.0; /* relative errors */ +/* For automatic degree and X0g setting. */ +/* + If automatic == 1, then the series is reevaluated as long as t_success!=1 + by increasing X0g (evaluation point) and M_m (approx degree); + */ +static int M_automatic=1; +/* Estimated degree bound for series expansion. See mh_t */ +static int M_m_estimated_approx_deg=0; +/* Let F(i) be the approximation up to degree i. + The i-th series_error is defined + by |(F(i)-F(i-1))/F(i-1)|. +*/ +static double M_series_error; +/* + M_series_error < M_assigend_series_error (A) is required for the + estimated_approx_deg. + */ +static double M_assigned_series_error=M_ASSIGNED_SERIES_ERROR_DEFAULT; +/* + Let Ef be the exponential factor ( Ef=(4)/1F1 of [HNTT] ) + If F(M_m)*Ef < x0value_min (B), the success=0 and X0g is increased. + Note that minimal double is about 2e-308 + */ +static double M_x0value_min=1e-60; +/* + estimated_X0g is the suggested value of X0g. + */ +static double M_estimated_X0g=0.0; +/* + X0g should be less than M_X0g_bound. + */ +static double M_X0g_bound = 1e+100; +/* + success is set to 1 when (A) and (B) are satisfied. + */ +static int M_mh_t_success=1; +/* + recommended_abserr is the recommended value of the absolute error + for the Runge-Kutta method. It is defined as + assigend_series_error(standing for significant digits)*Ig[0](initial value) + */ +static double M_recommended_abserr; +/* + recommended_relerr is the recommended value of the relative error + for the Runge-Kutta method.. + */ +static double M_recommended_relerr; +/* + max of beta(i)*x/2 + */ +static double M_beta_i_x_o2_max; +/* + minimum of |beta_i-beta_j| + */ +static double M_beta_i_beta_j_min; +/* + Value of matrix hg +*/ +static double M_mh_t_value; +/* + Show the process of updating degree. + */ +int M_show_autosteps=1; + /* prototypes */ static void *mymalloc(int size); static int myfree(void *p); @@ -104,25 +183,18 @@ static int mysum(int L[]); static int plength(int P[]); static int plength_t(int P[]); static void ptrans(int P[M_nmx],int Pt[]); -static int test_ptrans(); static int huk(int K[],int I,int J); static int hdk(int K[],int I,int J); 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[]); -static int printp2(int kappa[]); -static int test_beta(); static double q3_10(int K[],int M[],int SK); -static double q3_5(double A[],double B[],int K[],int I); -static void mtest4(); -static void mtest4b(); static int nk(int KK[]); -static int plength2(int P1[],int P2[]); static int myeq(int P1[],int P2[]); static int pListPartition(int M,int N); static int pListPartition2(int Less,int From,int To, int M); @@ -138,34 +210,98 @@ static int genDarray2(int M,int N); static int isHStrip(int Kap[],int Nu[]); static void hsExec_beta(void); static int genBeta(int Kap[]); -static int checkBeta1(); static int psublen(int Kap[],int Mu[]); static int genJack(int M,int N); -static int checkJack1(int M,int N); -static int checkJack2(int M,int N); -static int mtest1b(); static int imypower(int x,int n); static int usage(); static int setParamDefault(); static int next(struct SFILE *fp,char *s,char *msg); -static int gopen_file(void); 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); -double mh_t(double A[A_LEN],double B[B_LEN],int N,int M); +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[]); +static int test_beta(); +static void mtest4(); +static void mtest4b(); +static int plength2(int P1[],int P2[]); +static int checkBeta1(); +static int checkJack1(int M,int N); +static int checkJack2(int M,int N); +static int mtest1b(); +static double q3_5(double A[],double B[],int K[],int I); +#endif + +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; i M_m_MAX-2) myerror("xval, p is too large."); if (p < 0) { myerror("xval, p is negative."); - printf("ii=%d, p=%d\n",ii,p); + oxprintf("ii=%d, p=%d\n",ii,p); mh_exit(-1); } return(Xarray[ii-1][p]); @@ -295,7 +433,7 @@ static int mysum(int L[]) { } /* - (3,2,2,0,0) --> 3 + (3,2,2,0,0) --> 3 */ static int plength(int P[]) { int I; @@ -314,7 +452,7 @@ static int plength_t(int P[]) { } /* - ptrans(P) returns Pt + ptrans(P) returns Pt */ static void ptrans(int P[M_nmx],int Pt[]) { /* Pt[M_m] */ extern int M_m; @@ -329,6 +467,7 @@ static void ptrans(int P[M_nmx],int Pt[]) { /* Pt[M_m] } } +#ifdef STANDALONE static int test_ptrans() { extern int M_m; int p[M_n0]={5,3,2}; @@ -336,10 +475,11 @@ static int test_ptrans() { int i; M_m = 10; ptrans(p,pt); - if (Debug) {for (i=0; i<10; i++) printf("%d,",pt[i]); printf("\n");} + if (Debug) {for (i=0; i<10; i++) oxprintf("%d,",pt[i]); oxprintf("\n");} + return(0); } +#endif - /* upper hook length h_kappa^*(K) @@ -349,7 +489,7 @@ static int huk(int K[],int I,int J) { int Kp[M_m_MAX]; int A,H; A=Alpha; - /*printf("h^k(%a,%a,%a,%a)\n",K,I,J,A);*/ + /*oxprintf("h^k(%a,%a,%a,%a)\n",K,I,J,A);*/ ptrans(K,Kp); H=Kp[J-1]-I+A*(K[I-1]-J+1); return(H); @@ -364,7 +504,7 @@ static int hdk(int K[],int I,int J) { int Kp[M_m_MAX]; int A,H; A = Alpha; - /*printf("h_k(%a,%a,%a,%a)\n",K,I,J,A);*/ + /*oxprintf("h_k(%a,%a,%a,%a)\n",K,I,J,A);*/ ptrans(K,Kp); H=Kp[J-1]-I+1+A*(K[I-1]-J); return(H); @@ -374,9 +514,9 @@ static int hdk(int K[],int I,int J) { */ static double jjk(int K[]) { extern int Alpha; - int A,L,I,J; + int L,I,J; double V; - A=Alpha; + V=1; L=plength(K); for (I=0; I Q) { + for (I=0; I= M_kap[From], ..., M_kap[To], |(M_kap[From],...,M_kap[To])|<=M, */ static int pListPartition2(int Less,int From,int To, int M) { - int I,R; + int I; mh_check_intr(100); if (To < From) { - (*M_pExec)(); return(0); + (*M_pExec)(); return(0); } for (I=1; (I<=Less) && (I<=M) ; I++) { M_kap[From-1] = I; - R = pListPartition2(I,From+1,To,M-I); + pListPartition2(I,From+1,To,M-I); } return(1); } /* - partition に対してやる仕事をこちらへ書く. + Commands to do for each partition are given here. */ static void pExec_0() { if (Debug) { - printf("M_kap="); - printp(M_kap); - printf("\n"); + oxprintf("M_kap="); + printp(M_kap); + oxprintf("\n"); } } /* Test. - Compare pListPartition(4,3); genDarray(4,3); - Compare pListPartition(5,3); genDarray(5,3); + Compare pListPartition(4,3); genDarray(4,3); + Compare pListPartition(5,3); genDarray(5,3); */ /* -main() { + main() { M_pExec = pExec_0; pListPartition(5,3); -} + } */ @@ -752,7 +911,7 @@ static int pListHS(int Kap[],int N) { HS_n = N; /* Clear HS_mu. Do not forget when N < M_n */ for (i=0; i= M_n) { - if (Debug) {fprintf(stderr,"Ksize >= M_n\n");} - continue; - } - for (i=0; i= M_n) { + if (Debug) {oxprintfe("Ksize >= M_n\n");} + continue; + } + for (i=0; i=0; J--) { if (M_beta_1[J] == Nnu) { - K=I+1; - if (Debug) { - printf("Found at J=%d, K=%d, q3_10(Kap,Nu,K)=%lf,Nu,Mu= \n", - J,K,q3_10(M_beta_kap,Nu,K)); - printp(Nu); printf("\n"); - printp(Mu); printf("\n"); - } - /* Check other conditions. See Numata's mail on Dec 24, 2011. */ - rrMax = Nu[I]-1; - if ((plength_t(Kapt) < rrMax) || (plength_t(Nut) < rrMax)) { - if (Debug) printf(" is not taken (length). \n"); - break; - } - OK=1; - for (RR=0; RR= 2^I) aM_jack(I,J,K) = 0; - else aM_jack(I,J,K) = NAN; + if (J >= two_to_I) aM_jack(I,J,K) = 0; /* J >= 2^I */ + else aM_jack(I,J,K) = NAN; } } } @@ -1124,7 +1286,7 @@ static int genJack(int M,int N) { for (J=1; J 0. */ for (J=1; J0) partial_sum[i] += partial_sum[i-1]; + if (i>0) serror = myabs((partial_sum[i]-partial_sum[i-1])/partial_sum[i-1]); + if ((i>0)&&(M_m_estimated_approx_deg < 0)&&(serror M_m) M_mh_t_success=0; + + M_series_error = serror; + M_recommended_abserr = iv*M_assigned_series_error; + M_recommended_relerr = M_series_error; + + if (M_show_autosteps) { + oxprintf("%%%%serror=%lg, M_assigned_series_error=%lg, M_m_estimated_approx_deg=%d,M_m=%d\n",serror,M_assigned_series_error,M_m_estimated_approx_deg,M_m); + oxprintf("%%%%x0value_min=%lg, x0g_bound=%lg\n",M_x0value_min, M_X0g_bound); + oxprintf("%%%%F=%lg,Ef=%lg,M_estimated_X0g=%lg, X0g=%lg\n",F,iv_factor(),M_estimated_X0g,X0g); + oxprintfe("%%%%(stderr) serror=%lg, M_assigned_series_error=%lg, M_m_estimated_approx_deg=%d,M_m=%d\n",serror,M_assigned_series_error,M_m_estimated_approx_deg,M_m); + oxprintfe("%%%%(stderr) x0value_min=%lg, x0g_bound=%lg\n",M_x0value_min, M_X0g_bound); + oxprintfe("%%%%(stderr) F=%lg,Ef=%lg,iv=|F*Ef|=%lg,M_estimated_X0g=%lg, X0g=%lg\n",F,iv_factor(),iv,M_estimated_X0g,X0g); + } + + M_mh_t_value=F; return(F); } double mh_t2(int J) { @@ -1278,11 +1497,12 @@ double mh_t2(int J) { F = 0; Pmn = P_pmn; for (K=0; K= argc) { fprintf(stderr,"Option argument is not given.\n"); return(NULL); }} +#define inci(i) { i++; if (i >= argc) { oxprintfe("Option argument is not given.\n"); return(NULL); }} static int imypower(int x,int n) { int i; @@ -1324,23 +1545,48 @@ static int imypower(int x,int n) { } #ifdef STANDALONE2 -main(int argc,char *argv[]) { +int main(int argc,char *argv[]) { mh_exit(MH_RESET_EXIT); -/* jk_main(argc,argv); - printf("second run.\n"); */ + /* jk_main(argc,argv); + oxprintf("second run.\n"); */ jk_main(argc,argv); + return(0); } #endif struct MH_RESULT *jk_main(int argc,char *argv[]) { - double *y0; - double x0,xn; - double ef; - int i,j,rank; - double a[1]; double b[1]; + int i; + struct MH_RESULT *ans; + extern int M_automatic; + extern int M_mh_t_success; + extern double M_estimated_X0g; + extern int M_m_estimated_approx_deg; + for (i=1; imessage = NULL; + ans->t_success = 0; + ans->series_error = 1.0e+10; + ans->recommended_abserr = 1.0e-10; + } else ans = NULL; + if (M_automatic) { + /* Differentiation can be M_m in the bit pattern in the M_n variable case.*/ + if (M_n > Mapprox) Mapprox=M_n; + } /* Output by a file=stdout */ ofp = mh_fopen("stdout","w",JK_byFile); sprintf(swork,"%%%%Use --help option to see the help.\n"); mh_fputs(swork,ofp); sprintf(swork,"%%%%Mapprox=%d\n",Mapprox); mh_fputs(swork,ofp); if (M_n != Mg) { - myerror("Mg must be equal to M_n\n"); mh_exit(-1); + myerror("Mg must be equal to M_n\n"); mh_exit(-1); } if (Debug) showParam(NULL,1); + setM_x(); + + M_beta_i_x_o2_max=myabs(M_x[0]/2); + if (M_n <= 1) M_beta_i_beta_j_min = myabs(Beta[0]); + else M_beta_i_beta_j_min = myabs(Beta[1]-Beta[0]); for (i=0; i M_beta_i_x_o2_max) M_beta_i_x_o2_max = myabs(M_x[i]/2); + for (j=i+1; jx = X0g; - ans->rank = imypower(2,Mg); - ans->y = (double *)mymalloc(sizeof(double)*(ans->rank)); - for (i=0; irank; i++) (ans->y)[i] = Iv[i]; - ans->size=1; - ans->sfpp = (struct SFILE **)mymalloc(sizeof(struct SFILE *)*(ans->size)); - (ans->sfpp)[0] = ofp; + if (!JK_byFile) { + ans->x = X0g; + ans->rank = imypower(2,Mg); + ans->y = (double *)mymalloc(sizeof(double)*(ans->rank)); + for (i=0; irank; i++) (ans->y)[i] = Iv[i]; + ans->size=1; + ans->sfpp = (struct SFILE **)mymalloc(sizeof(struct SFILE *)*(ans->size)); + (ans->sfpp)[0] = ofp; + + ans->t_success = M_mh_t_success; + ans->series_error = M_series_error; + ans->recommended_abserr = M_recommended_abserr; } - if (Debug) printf("jk_freeWorkArea() starts\n"); + if (Debug) oxprintf("jk_freeWorkArea() starts\n"); jk_freeWorkArea(); - if (Debug) printf("jk_freeWorkArea() has finished.\n"); + if (Debug) oxprintf("jk_freeWorkArea() has finished.\n"); return(ans); } static int usage() { - fprintf(stderr,"Usages:\n"); - fprintf(stderr,"mh-m [--idata input_data_file --x0 x0 --degree approxm]\n"); - fprintf(stderr,"\nThe command mh-m [options] generates an input for w-m, Pr({y | ytest2.txt\n"); - fprintf(stderr," ./w-3 --idata test2.txt --gnuplotf test-g\n"); - fprintf(stderr," gnuplot -persist s); - mh_exit(-1); + 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); Beta = (double *)mymalloc(sizeof(double)*Mg); 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); } - +#ifdef STANDALONE +/* may remove */ +static int showParam_v1(struct SFILE *fp,int fd) { + int rank,i; + char swork[1024]; + if (fd) { + fp = mh_fopen("stdout","w",1); + } + rank = imypower(2,Mg); + sprintf(swork,"%%Mg=\n%d\n",Mg); 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); + 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