/* Copyright Jean-Philippe Chancelier
ENPC */
#include <string.h>
#include "../../routines/stack-c.h"
#if WIN32
#include "../os_specific/win_mem_alloc.h"
extern char *GetExceptionString(DWORD ExceptionCode);
#endif
/** external functions to be called through this interface **/
#ifdef __STDC__
void sciprint(char *fmt,...);
#else
/*VARARGS0*/
void sciprint(char *, ...);
#endif
extern int C2F(cdfbet) __PARAMS((int *,double *,double *,double *,double *,double *,double *, int *,double *));
extern int C2F(cdfnbn) __PARAMS((int *,double *,double *,double *,double *,double *,double *, int *,double *));
extern int C2F(cdffnc) __PARAMS((int *,double *,double *,double *,double *,double *,double *, int *,double *));
extern int C2F(cdfbin) __PARAMS((int *,double *,double *,double *,double *,double *,double *, int *,double *));
extern int C2F(cdfchi) __PARAMS((int *,double *,double *,double *,double *, int *,double *));
extern int C2F(cdft) __PARAMS((int *,double *,double *,double *,double *, int *,double *));
extern int C2F(cdfpoi) __PARAMS((int *,double *,double *,double *,double *, int *,double *));
extern int C2F(cdff) __PARAMS((int *,double *,double *,double*,double *,double *, int *,double *));
extern int C2F(cdfgam) __PARAMS((int *,double *,double *,double*,double *,double *, int *,double *));
extern int C2F(cdff) __PARAMS((int *,double *,double *,double*,double *,double *, int *,double *));
extern int C2F(cdfchn) __PARAMS((int *,double *,double *,double*,double *,double *, int *,double *));
extern int C2F(cdfnor) __PARAMS((int *,double *,double *,double*,double *,double *, int *,double *));
static int CdfBase __PARAMS((char *fname,int inarg,int oarg,int *callpos,char *option,char *errnames,int which,int (*fonc)(),void (*foncErr)()));
static void cdfbetErr __PARAMS((int status,double bound));
static void cdfbinErr __PARAMS((int status,double bound));
static void cdfchiErr __PARAMS((int status,double bound));
static void cdffErr __PARAMS((int status,double bound));
static void cdffncErr __PARAMS((int status,double bound));
static void cdfgamErr __PARAMS((int status,double bound));
static void cdfnbnErr __PARAMS((int status,double bound));
static void cdfnorErr __PARAMS((int status,double bound));
static void cdfpoiErr __PARAMS((int status,double bound));
static void cdftErr __PARAMS((int status,double bound));
static void cdfchnErr __PARAMS((int status,double bound));
/**************************************************
* hand written interface
* Interface for cdfbet
*
* SUBROUTINE CDFBET( WHICH, P, Q, X, Y, A, B, STATUS, BOUND )
* Cumulative Distribution Function
* BETa Distribution
***********************************************************************/
int cdfbetI(char* fname,unsigned long l)
{
int minrhs = 5,maxrhs = 6,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[6] = {4,5,0,1,2,3};
CdfBase(fname,4,2,callpos,"PQ","X,Y,A and B",1,C2F(cdfbet),
cdfbetErr);
}
else if ( strcmp(cstk(l1),"XY")==0)
{
static int callpos[6] = {2,3,4,5,0,1};
CdfBase(fname,4,2,callpos,"XY","A,B,P and Q",2,C2F(cdfbet),
cdfbetErr);
}
else if ( strcmp(cstk(l1),"A")==0)
{
static int callpos[6] = {1,2,3,4,5,0};
CdfBase(fname,5,1,callpos,"A","B,P,Q,X and Y",3,C2F(cdfbet),
cdfbetErr);
}
else if ( strcmp(cstk(l1),"B")==0)
{
static int callpos[6] = {0,1,2,3,4,5};
CdfBase(fname,5,1,callpos,"B","P,Q,X,Y and A",4,C2F(cdfbet),
cdfbetErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
return 0;
}
return 0;
}
static void cdfbetErr(status,bound)
int status;
double bound;
{
static char param[]="-PQXYAB";
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
case 4 : Scierror(999," X + Y .ne. 1 \r\n");break;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdfbin
*
* SUBROUTINE CDFBIN ( WHICH, P, Q, S, XN, PR, OMPR, STATUS, BOUND )
* Cumulative Distribution Function
* BINomial distribution
***********************************************************************/
int cdfbinI(char* fname,unsigned long l)
{
int minrhs = 5,maxrhs = 6,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[6] = {4,5,0,1,2,3};
CdfBase(fname,4,2,callpos,"PQ","S,Xn,Pr and Ompr",1,C2F(cdfbin),
cdfbinErr);
}
else if ( strcmp(cstk(l1),"S")==0)
{
static int callpos[6] = {3,4,5,0,1,2};
CdfBase(fname,5,1,callpos,"S","Xn,Pr,Ompr,P and Q",2,C2F(cdfbin),
cdfbinErr);
}
else if ( strcmp(cstk(l1),"Xn")==0)
{
static int callpos[6] = {2,3,4,5,0,1};
CdfBase(fname,5,1,callpos,"Xn","Pr,OMPr,P,Q and S",3,C2F(cdfbin),
cdfbinErr);
}
else if ( strcmp(cstk(l1),"PrOmpr")==0)
{
static int callpos[6] = {0,1,2,3,4,5};
CdfBase(fname,4,2,callpos,"PrOmpr","P,Q,S and Xn",4,C2F(cdfbin),
cdfbinErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdfbinErr(status,bound)
int status;
double bound;
{
static char *param[7]={"Which", "P","Q","Pr","Ompr","S","Xn"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
case 4 : Scierror(999," Pr + Ompr .ne. 1 \r\n");break;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdfchi
*
* SUBROUTINE CDFCHI( WHICH, P, Q, X, DF, STATUS, BOUND )
* Cumulative Distribution Function
* CHI-Square distribution
***********************************************************************/
int cdfchiI(char* fname,unsigned long l)
{
int minrhs = 3,maxrhs = 4,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[4] = {2,3,0,1};
CdfBase(fname,2,2,callpos,"PQ","X and Df",1,C2F(cdfchi),
cdfchiErr);
}
else if ( strcmp(cstk(l1),"X")==0)
{
static int callpos[4] = {1,2,3,0};
CdfBase(fname,3,1,callpos,"X","Df, P and Q",2,C2F(cdfchi),
cdfchiErr);
}
else if ( strcmp(cstk(l1),"Df")==0)
{
static int callpos[4] = {0,1,2,3};
CdfBase(fname,3,1,callpos,"Df","P,Q and X",3,C2F(cdfchi),
cdfchiErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdfchiErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","X","Df"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
case 10 : Scierror(999,"cdfchi: Error in cumgam\r\n");break;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdff
* Cumulative Distribution Function
* F distribution
***********************************************************************/
int cdffI(char* fname,unsigned long l)
{
int minrhs = 4,maxrhs = 5,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[5] = {3,4,0,1,2};
CdfBase(fname,3,2,callpos,"PQ","F,Dfn and Dfd",1,C2F(cdff),
cdffErr);
}
else if ( strcmp(cstk(l1),"F")==0)
{
static int callpos[5] = {2,3,4,0,1};
CdfBase(fname,4,1,callpos,"F","Dfn,Dfd,P and Q",2,C2F(cdff),
cdffErr);
}
else if ( strcmp(cstk(l1),"Dfn")==0)
{
static int callpos[5] = {1,2,3,4,0};
CdfBase(fname,4,1,callpos,"Dfn","Dfd,P,Q and F",3,C2F(cdff),
cdffErr);
}
else if ( strcmp(cstk(l1),"Dfd")==0)
{
static int callpos[5] = {0,1,2,3,4};
CdfBase(fname,4,1,callpos,"Dfd","P,Q,F and Dfn",4,C2F(cdff),
cdffErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdffErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","F","Dfn","Dfd"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdffnc
* Cumulative Distribution Function
* Non-central F distribution
***********************************************************************/
int cdffncI(char* fname,unsigned long l)
{
int minrhs = 5,maxrhs = 6,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[6] = {4,5,0,1,2,3};
CdfBase(fname,4,2,callpos,"PQ","F,Dfn,Dfd and Pnonc",1,C2F(cdffnc),
cdffncErr);
}
else if ( strcmp(cstk(l1),"F")==0)
{
static int callpos[6] = {3,4,5,0,1,2};
CdfBase(fname,5,1,callpos,"F","Dfn,Dfd,Pnonc,P and Q",2,C2F(cdffnc),
cdffncErr);
}
else if ( strcmp(cstk(l1),"Dfn")==0)
{
static int callpos[6] = {2,3,4,5,0,1};
CdfBase(fname,5,1,callpos,"Dfn","Dfd,Pnonc,P,Q and F",3,C2F(cdffnc),
cdffncErr);
}
else if ( strcmp(cstk(l1),"Dfd")==0)
{
static int callpos[6] = {1,2,3,4,5,0};
CdfBase(fname,5,1,callpos,"Dfd","Pnonc,P,Q,F and Dfn",4,C2F(cdffnc),
cdffncErr);
}
else if ( strcmp(cstk(l1),"Pnonc")==0)
{
static int callpos[6] = {0,1,2,3,4,5};
CdfBase(fname,5,1,callpos,"Pnonc","P,Q,F,Dfn and Dfd",5,C2F(cdffnc),
cdffncErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdffncErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","F","Dfn","Dfd","Pnonc"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdfgam
* Cumulative Distribution Function
* F distribution
***********************************************************************/
int cdfgamI(char* fname,unsigned long l)
{
int minrhs = 4,maxrhs = 5,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[5] = {3,4,0,1,2};
CdfBase(fname,3,2,callpos,"PQ","X,Shape and Scale",1,C2F(cdfgam),
cdfgamErr);
}
else if ( strcmp(cstk(l1),"X")==0)
{
static int callpos[5] = {2,3,4,0,1};
CdfBase(fname,4,1,callpos,"X","Shape,Scale,P and Q",2,C2F(cdfgam),
cdfgamErr);
}
else if ( strcmp(cstk(l1),"Shape")==0)
{
static int callpos[5] = {1,2,3,4,0};
CdfBase(fname,4,1,callpos,"Shape","Scale,P,Q and X",3,C2F(cdfgam),
cdfgamErr);
}
else if ( strcmp(cstk(l1),"Scale")==0)
{
static int callpos[5] = {0,1,2,3,4};
CdfBase(fname,4,1,callpos,"Scale","P,Q,X and Shape",4,C2F(cdfgam),
cdfgamErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdfgamErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","X","Shape","Scale"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
case 10 : Scierror(999," cannot compute the answer \r\n");break ;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdfnbn
* SUBROUTINE cdfnbn(which,p,q,s,xn,pr,ompr,status,bound)
* Cumulative Distribution Function
* Negative BiNomial distribution
***********************************************************************/
int cdfnbnI(char* fname,unsigned long l)
{
int minrhs = 5,maxrhs = 6,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[6] = {4,5,0,1,2,3};
CdfBase(fname,4,2,callpos,"PQ","S,XN,PR and OMPR",1,C2F(cdfnbn),
cdfnbnErr);
}
else if ( strcmp(cstk(l1),"S")==0)
{
static int callpos[6] = {3,4,5,0,1,2};
CdfBase(fname,5,1,callpos,"S","XN,PR,OMPR,P and Q",2,C2F(cdfnbn),
cdfnbnErr);
}
else if ( strcmp(cstk(l1),"Xn")==0)
{
static int callpos[6] = {2,3,4,5,0,1};
CdfBase(fname,5,1,callpos,"Xn","PR,OMPR,P,Q and S",3,C2F(cdfnbn),
cdfnbnErr);
return 0;
}
else if ( strcmp(cstk(l1),"PrOmpr")==0)
{
static int callpos[6] = {0,1,2,3,4,5};
CdfBase(fname,4,2,callpos,"PrOmpr","P,Q,S and Xn",4,C2F(cdfnbn),
cdfnbnErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdfnbnErr(status,bound)
int status;
double bound;
{
static char param[]="-PQXYAB";
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
case 4 : Scierror(999," Pr + Ompr .ne. 1 \r\n");break;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdfnor
* Cumulative Distribution Function
* NORmal distribution
***********************************************************************/
int cdfnorI(char* fname,unsigned long l)
{
int minrhs = 4,maxrhs = 5,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[5] = {3,4,0,1,2};
CdfBase(fname,3,2,callpos,"PQ","X,Mean and Std",1,C2F(cdfnor),
cdfnorErr);
}
else if ( strcmp(cstk(l1),"X")==0)
{
static int callpos[5] = {2,3,4,0,1};
CdfBase(fname,4,1,callpos,"X","Mean,Std,P and Q",2,C2F(cdfnor),
cdfnorErr);
}
else if ( strcmp(cstk(l1),"Mean")==0)
{
static int callpos[5] = {1,2,3,4,0};
CdfBase(fname,4,1,callpos,"Mean","Std,P,Q and X",3,C2F(cdfnor),
cdfnorErr);
}
else if ( strcmp(cstk(l1),"Std")==0)
{
static int callpos[5] = {0,1,2,3,4};
CdfBase(fname,4,1,callpos,"Std","P,Q,X and Mean",4,C2F(cdfnor),
cdfnorErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdfnorErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","X","Mean","Std"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
case 4 : Scierror(999," Std must not be zero \r\n");break ;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdfpoi
* POIsson distribution
***********************************************************************/
int cdfpoiI(char* fname,unsigned long l)
{
int minrhs = 3,maxrhs = 4,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[4] = {2,3,0,1};
CdfBase(fname,2,2,callpos,"PQ","S and Xlam",1,C2F(cdfpoi),
cdfpoiErr);
}
else if ( strcmp(cstk(l1),"S")==0)
{
static int callpos[4] = {1,2,3,0};
CdfBase(fname,3,1,callpos,"S","Xlam,P and Q",2,C2F(cdfpoi),
cdfpoiErr);
}
else if ( strcmp(cstk(l1),"Xlam")==0)
{
static int callpos[4] = {0,1,2,3};
CdfBase(fname,3,1,callpos,"Xlam","P,Q and S",3,C2F(cdfpoi),
cdfpoiErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdfpoiErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","S","Xlam"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdft
* T distribution
***********************************************************************/
int cdftI(char* fname,unsigned long l)
{
int minrhs = 3,maxrhs = 4,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[4] = {2,3,0,1};
CdfBase(fname,2,2,callpos,"PQ","T and Df",1,C2F(cdft),
cdftErr);
}
else if ( strcmp(cstk(l1),"T")==0)
{
static int callpos[4] = {1,2,3,0};
CdfBase(fname,3,1,callpos,"T","Df, P and Q",2,C2F(cdft),
cdftErr);
}
else if ( strcmp(cstk(l1),"Df")==0)
{
static int callpos[4] = {0,1,2,3};
CdfBase(fname,3,1,callpos,"Df","P,Q and T",3,C2F(cdft),
cdftErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdftErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","T","Df"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
/**************************************************
* hand written interface
* Interface for cdfchn
* Non-central Chi-Square
***********************************************************************/
int cdfchnI(char* fname,unsigned long l)
{
int minrhs = 4,maxrhs = 5,minlhs=1,maxlhs=2,m1,n1,l1;
Nbvars = 0;
CheckRhs(minrhs,maxrhs);
CheckLhs(minlhs,maxlhs);
GetRhsVar(1, "c", &m1, &n1, &l1);
if ( strcmp(cstk(l1),"PQ")==0)
{
static int callpos[5] = {3,4,0,1,2};
CdfBase(fname,3,2,callpos,"PQ","X,Df and Pnonc",1,C2F(cdfchn),
cdfchnErr);
}
else if ( strcmp(cstk(l1),"X")==0)
{
static int callpos[5] = {2,3,4,0,1};
CdfBase(fname,4,1,callpos,"X","Df,Pnonc,P and Q",2,C2F(cdfchn),
cdfchnErr);
}
else if ( strcmp(cstk(l1),"Df")==0)
{
static int callpos[5] = {1,2,3,4,0};
CdfBase(fname,4,1,callpos,"Df","Pnonc,P,Q and X",3,C2F(cdfchn),
cdfchnErr);
}
else if ( strcmp(cstk(l1),"Pnonc")==0)
{
static int callpos[5] = {0,1,2,3,4};
CdfBase(fname,4,1,callpos,"Pnonc","P,Q,X and Df",4,C2F(cdfchn),
cdfchnErr);
}
else
{
Scierror(999,"%s: Wrong first argument %s\r\n",fname,cstk(l1));
}
return 0;
}
static void cdfchnErr(status,bound)
int status;
double bound;
{
static char *param[7]={"X", "P","Q","F","Dfn","Dfd"};
switch ( status )
{
case 1 : Scierror(999,"answer appears to be lower than lowest search bound %f\r\n",bound);break;
case 2 : Scierror(999,"answer appears to be higher than greatest search bound %f\r\n",bound);break;
case 3 : Scierror(999," P + Q .ne. 1 \r\n");break ;
default :
Scierror(999,"input parameter %c is out of range \r\n\tbound exceeded: %f\r\n",
param[-status-1],bound);
}
}
static TabF Tab[]={
{cdfbetI, "cdfbet"},
{cdfbinI, "cdfbin"},
{cdfchiI, "cdfchi"},
{cdfchnI, "cdfchn"},
{cdffI, "cdff"},
{cdffncI, "cdffnc"},
{cdfgamI, "cdfgam"},
{cdfnbnI, "cdfnbn"},
{cdfnorI, "cdfnor"},
{cdfpoiI, "cdfpoi"},
{cdftI, "cdft"}
};
int C2F(dcd)()
{
Rhs = Max(0, Rhs);
#if WIN32
#ifndef _DEBUG
_try
{
(*(Tab[Fin-1].f))(Tab[Fin-1].name,strlen(Tab[Fin-1].name));
}
_except (EXCEPTION_EXECUTE_HANDLER)
{
char *ExceptionString=GetExceptionString(GetExceptionCode());
sciprint("Warning !!!\nScilab has found a critical error (%s)\nwith \"%s\" function.\nScilab may become unstable.\n",ExceptionString,Tab[Fin-1].name);
if (ExceptionString) {FREE(ExceptionString);ExceptionString=NULL;}
}
#else
(*(Tab[Fin-1].f))(Tab[Fin-1].name,strlen(Tab[Fin-1].name));
#endif
#else
(*(Tab[Fin-1].f))(Tab[Fin-1].name,strlen(Tab[Fin-1].name));
#endif
return 0;
}
static int CdfBase(fname,inarg,oarg,callpos,option,errnames,which,fonc,foncErr)
int inarg,oarg,callpos[],which;
char *option,*errnames,*fname;
int (*fonc)();
void (*foncErr)();
{
int i,status=0,m[6],n[6],l[6];
double bound;
if ( Rhs != inarg+1 )
{
Scierror(999,"%s: Rhs must be %d for '%s' option'\r\n",fname,inarg+1,option);
return 1;
}
for ( i = 0 ; i < inarg ; i++ )
{
GetRhsVar(i+2, "d", &m[i], &n[i], &l[i]);
}
for ( i = 1 ; i < inarg ; i++)
if ( m[i] != m[i-1] || n[i] != n[i-1])
{
Scierror(999,"%s %s must have same size\r\n",fname,errnames);
return 1;
}
for ( i = 0 ; i < oarg ; i++)
CreateVar(i+2+inarg,"d",&m[0],&n[0],&l[i+inarg]);
switch ( inarg+oarg)
{
case 5:
for ( i=0 ; i < m[0]*n[0]; i++)
{
(*fonc)(&which,stk(l[callpos[0]]+i),stk(l[callpos[1]]+i),
stk(l[callpos[2]] +i),stk(l[callpos[3]]+i),
stk(l[callpos[4]]+i),
&status,&bound);
if (status != 0)
{
(*foncErr)(status,bound); return 1;
}
}
break;
case 6:
for ( i=0 ; i < m[0]*n[0]; i++)
{
(*fonc)(&which,stk(l[callpos[0]]+i),stk(l[callpos[1]]+i),
stk(l[callpos[2]] +i),stk(l[callpos[3]]+i),
stk(l[callpos[4]] +i),stk(l[callpos[5]]+i),
&status,&bound);
if (status != 0)
{
/** Scierror(999,"i=%d\r\n",i); **/
(*foncErr)(status,bound); return 1;
}
}
break;
case 4:
for ( i=0 ; i < m[0]*n[0]; i++)
{
(*fonc)(&which,stk(l[callpos[0]]+i),stk(l[callpos[1]]+i),
stk(l[callpos[2]] +i),stk(l[callpos[3]]+i),
&status,&bound);
if (status != 0)
{
(*foncErr)(status,bound); return 1;
}
}
break;
}
for ( i = 0 ; i < oarg ; i++)
LhsVar(i+1) = i+2+inarg;
PutLhsVar();
return 0;
}
syntax highlighted by Code2HTML, v. 0.9.1