void _GDL_OBJECT_OverloadBracketsLeftSide( EnvUDT* e)
{
// // debug/check
// std::cout << "_GDL_OBJECT_OverloadBracketsLeftSide called" << std::endl;
// this is only called on scalar object references
// IDL's default behavior is to just replace SELF (via OBJREF) by RVALUE
// no index checking is done.
SizeT nParam = e->NParam();
if( nParam < 3) // consider implicit SELF
return; // RVALUE not given -> ignore
// BaseGDL** objRef = e->GetKW(1);
// BaseGDL** objRefP = e->GetPtrTo( objRef);
if( !e->GlobalKW(1))
{
ThrowFromInternalUDSub( e, "Parameter 1 (OBJREF) must be a passed as reference in this context.");
}
BaseGDL** objRefP = &e->GetKW(1);
BaseGDL* objRef = *objRefP;
BaseGDL* rValue = e->GetKW(2);
if( rValue == NULL)
{
ThrowFromInternalUDSub( e, "Parameter 2 (RVALUE) is undefined.");
}
if( rValue->Type() != GDL_OBJ)
{
ThrowFromInternalUDSub( e, "Parameter 2 (RVALUE) must be an OBJECT in this context.");
}
GDLDelete( *objRefP);
*objRefP = rValue->Dup();
}
// grabs c
CArrayIndexIndexed( BaseGDL* c, bool strictArrSubs_ = false)
: strictArrSubs( strictArrSubs_)
, ix( NULL), ixDim( NULL)
, rawData( c)
{
assert( rawData != NULL);
if( rawData->Rank() == 0) // type ONE
{
rawData->Scalar2RangeT(sInit);
s = sInit; // in case of assoc NIter is not called
isScalar = true;
return;
}
// type INDEXED
isScalar = false;;
ixDim = &rawData->Dim();
assert( rawData->Type() != GDL_UNDEF);
DType dType = rawData->Type();
int typeCheck = DTypeOrder[ dType];
if( typeCheck >= 100)
throw GDLException(-1, NULL,"Type not allowed as subscript.",true,false);
if( strictArrSubs)
ix = new (ixBuf) AllIxIndicesStrictT( rawData);
else
ix = new (ixBuf) AllIxIndicesT( rawData);
}
void AssureScalarPar( SizeT pIx, typename T::Ty& scalar)
{
BaseGDL* p = GetParDefined( pIx);
if( p->Type() != T::t)
Throw( "Variable must be a "+T::str+" in this context: "+
GetParString(pIx));
T* tp= static_cast<T*>(p);
if( !tp->Scalar( scalar))
Throw("Variable must be a scalar in this context: "+
GetParString(pIx));
}
T* GetParAs( SizeT pIx)
{
BaseGDL* p = GetParDefined( pIx);
if( p->Type() == T::t)
return static_cast<T*>( p);
// T* res = dynamic_cast<T*>( p);
// if( res != NULL) return res;
T* res = static_cast<T*>( p->Convert2( T::t, BaseGDL::COPY));
this->DeleteAtExit( res);
return res;
}
T* IfDefGetKWAs( SizeT ix)
{
BaseGDL* p = GetKW( ix);
if( p == NULL) return NULL;
if( p->Type() == T::t)
return static_cast<T*>( p);
// T* res = dynamic_cast<T*>( p);
// if( res != NULL) return res;
T* res = static_cast<T*>( p->Convert2( T::t, BaseGDL::COPY));
this->DeleteAtExit( res);
return res;
}
T* GetKWAs( SizeT ix)
{
BaseGDL* p = GetKW( ix);
if( p == NULL)
Throw( "Keyword is undefined: "+GetString( ix));
if( p->Type() == T::t)
return static_cast<T*>( p);
// T* res = dynamic_cast<T*>( p);
// if( res != NULL) return res;
T* res = static_cast<T*>( p->Convert2( T::t, BaseGDL::COPY));
this->DeleteAtExit( res);
return res;
}
void AssureScalarKW( SizeT ix, typename T::Ty& scalar)
{
BaseGDL* p = GetKW( ix);
if( p == NULL)
Throw("Keyword undefined: "+GetString(ix));
if( p->Type() != T::t)
Throw("Keyword must be a "+T::str+" in this context: "+
GetString(ix));
T* tp= static_cast<T*>(p);
if( !tp->Scalar( scalar))
Throw("Keyword must be a scalar in this context: "+
GetString(ix));
}
void print_vmsCompat( EnvT* e, int* parOffset)
{
// SA: handling special VMS-compatibility syntax, e.g.: print, '$(F)', 100
// (if FORMAT not defined, more than 2 params, first param is scalar string
// and begins with "$(" then first param minus "$" is treated as FORMAT)
if (e->GetKW(0) == NULL && e->NParam() > 1 + *parOffset)
{
BaseGDL* par = e->GetParDefined(*parOffset);
if (par->Type() == GDL_STRING && par->Scalar() &&
(*static_cast<DStringGDL*>(par))[0].compare(0,2,"$(") == 0)
{
e->SetKeyword("FORMAT",
new DStringGDL((*static_cast<DStringGDL*>(par))[0].c_str()+1));
(*parOffset)++;
}
}
}
BaseGDL* _GDL_OBJECT_OverloadEQOp( EnvUDT* e)
{
SizeT nParam = e->NParam(); // number of parameters actually given
// int envSize = e->EnvSize(); // number of parameters + keywords 'e' (pro) has defined
if( nParam < 2) // consider implicit SELF
ThrowFromInternalUDSub( e, "2 parameters are needed: LEFT, RIGHT.");
// default behavior: Exact like scalar indexing
BaseGDL* l = e->GetKW(1);
if( l->Type() != GDL_OBJ)
ThrowFromInternalUDSub( e, "Unable to convert parameter #1 to type object reference.");
BaseGDL* r = e->GetKW(2);
if( r->Type() != GDL_OBJ)
ThrowFromInternalUDSub( e, "Unable to convert parameter #2 to type object reference.");
DObjGDL* left = static_cast<DObjGDL*>(l);
DObjGDL* right = static_cast<DObjGDL*>(r);
ULong rEl=right->N_Elements();
ULong nEl=left->N_Elements();
// if( nEl == 0)
// nEl=N_Elements();
assert( rEl);
assert( nEl);
// if( !rEl || !nEl) throw GDLException("Variable is undefined.");
Data_<SpDByte>* res;
DObj s;
if( right->StrictScalar(s))
{
res= new Data_<SpDByte>( left->Dim(), BaseGDL::NOZERO);
if( nEl == 1)
{
(*res)[0] = (s == (*left)[0]);
return res;
}
TRACEOMP( __FILE__, __LINE__)
#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
{
#pragma omp for
for( OMPInt i=0; i < nEl; ++i)
(*res)[i] = ((*left)[i] == s);
} }
T* fftw_template(EnvT* e, BaseGDL* p0,
SizeT nEl, SizeT dbl, SizeT overwrite, double direct, bool recenter) {
int dim[MAXRANK];
T* res;
BaseGDL* data;
Guard<BaseGDL> guard_data;
// if recenter and inverse (direct > 0) we will work on a "de-centered" p0 variant.
// and of course not center the result.
if (recenter && direct == 1)
{
DLong centerIx[ MAXRANK];
for (int i = 0; i < p0->Rank(); ++i) centerIx[i] = (p0->Dim(i)%2==1)?((p0->Dim(i))/2)+1:((p0->Dim(i))/2);
data = p0->CShift(centerIx);
recenter = false;
guard_data.Reset(data);
} else data = p0;
if (overwrite == 0)
res = new T(data->Dim(), BaseGDL::ZERO);
else
{
res = (T*) p0; //we overwrite the real p0.
if (e->GlobalPar(0)) e->SetPtrToReturnValue(&e->GetPar(0));
}
for (SizeT i = 0; i < data->Rank(); ++i)
{
dim[i] = (int) data->Dim(data->Rank() - i - 1);
}
DComplexDblGDL* p0C = static_cast<DComplexDblGDL*> (data);
DComplexGDL* p0CF = static_cast<DComplexGDL*> (data);
if (data->Type() == GDL_COMPLEXDBL)
{
double *dptr;
dptr = (double*) &(*res)[0];
fftw_plan p;
fftw_complex *in, *out;
in = (fftw_complex *) &(*p0C)[0];
out = (fftw_complex *) & dptr[0];
p = fftw_plan_dft((int) data->Rank(), dim, in, out, (int) direct, FFTW_ESTIMATE);
fftw_execute(p);
if (direct == -1)
{
// TRACEOMP(__FILE__, __LINE__)
#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
{
#pragma omp for
for (OMPInt i = 0; i < nEl; ++i)
{
out[i][0] /= nEl;
out[i][1] /= nEl;
}
}
}
// 02 06 2010
//cout << "fftw dest" << endl ;
fftw_destroy_plan(p); // 1
} else if (data->Type() == GDL_COMPLEX)
{
float *dptrf;
dptrf = (float*) &(*res)[0];
fftwf_plan p_f;
fftwf_complex *in_f, *out_f;
in_f = (fftwf_complex *) &(*p0CF)[0];
out_f = (fftwf_complex *) & dptrf[0];
p_f = fftwf_plan_dft((int) data->Rank(), dim, in_f, out_f, (int) direct, FFTW_ESTIMATE);
fftwf_execute(p_f);
if (direct == -1)
{
// TRACEOMP(__FILE__, __LINE__)
#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
{
#pragma omp for
for (OMPInt i = 0; i < nEl; ++i)
{
out_f[i][0] /= nEl;
out_f[i][1] /= nEl;
}
}
}
// 02 06 2010
//cout << "fftwF dest" << endl ;
fftwf_destroy_plan(p_f); // 2
}
if (recenter)
{
Guard<BaseGDL> guard_res(res);
DLong centerIx[ MAXRANK];
for (int i = 0; i < data->Rank(); ++i) centerIx[i] = (p0->Dim(i))/2;
return (T*) res->CShift(centerIx);
} else return res;
}
/*****************************************convol_fun*********************************************************/
BaseGDL* convol_fun( EnvT* e)
{
SizeT nParam=e->NParam( 2);
/************************************Checking_parameters************************************************/
BaseGDL* p0 = e->GetNumericParDefined( 0);
if( p0->Rank() == 0)
e->Throw( "Expression must be an array in this context: "+
e->GetParString(0));
BaseGDL* p1 = e->GetNumericParDefined( 1);
if( p1->Rank() == 0)
e->Throw( "Expression must be an array in this context: "+
e->GetParString(1));
if( p0->N_Elements() < p1->N_Elements())
e->Throw( "Incompatible dimensions for Array and Kernel.");
// rank 1 for kernel works always
if( p1->Rank() != 1)
{
SizeT rank = p0->Rank();
if( rank != p1->Rank())
e->Throw( "Incompatible dimensions for Array and Kernel.");
for( SizeT r=0; r<rank; ++r)
if( p0->Dim( r) < p1->Dim( r))
e->Throw( "Incompatible dimensions for Array and Kernel.");
}
/***************************************Preparing_matrices*************************************************/
// convert kernel to array type
Guard<BaseGDL> p1Guard;
if( p0->Type() == GDL_BYTE)
{
if( p1->Type() != GDL_INT)
{
p1 = p1->Convert2( GDL_INT, BaseGDL::COPY);
p1Guard.Reset( p1);
}
}
else if( p0->Type() != p1->Type())
{
p1 = p1->Convert2( p0->Type(), BaseGDL::COPY);
p1Guard.Reset( p1);
}
BaseGDL* scale;
Guard<BaseGDL> scaleGuard;
if( nParam > 2)
{
scale = e->GetParDefined( 2);
if( scale->Rank() > 0)
e->Throw( "Expression must be a scalar in this context: "+
e->GetParString(2));
// p1 here handles GDL_BYTE case also
if( p1->Type() != scale->Type())
{
scale = scale->Convert2( p1->Type(),BaseGDL::COPY);
scaleGuard.Reset( scale);
}
}
else
{
scale = p1->New( dimension(), BaseGDL::ZERO);
}
/********************************************Arguments_treatement***********************************/
bool center = true;
static int centerIx = e->KeywordIx( "CENTER");
if( e->KeywordPresent( centerIx))
{
DLong c;
e->AssureLongScalarKW( centerIx, c);
center = (c != 0);
}
// overrides EDGE_TRUNCATE
static int edge_wrapIx = e->KeywordIx( "EDGE_WRAP");
bool edge_wrap = e->KeywordSet( edge_wrapIx);
static int edge_truncateIx = e->KeywordIx( "EDGE_TRUNCATE");
bool edge_truncate = e->KeywordSet( edge_truncateIx);
static int edge_zeroIx = e->KeywordIx( "EDGE_ZERO");
bool edge_zero = e->KeywordSet( edge_zeroIx);
int edgeMode = 0;
if( edge_wrap)
edgeMode = 1;
else if( edge_truncate)
edgeMode = 2;
else if( edge_zero)
edgeMode = 3;
// p0, p1 and scale have same type
// p1 has rank of 1 or same rank as p0 with each dimension smaller than p0
// scale is a scalar
/***********************************Parameter_BIAS**************************************/
static int biasIx = e->KeywordIx("BIAS");
bool statusBias = e->KeywordPresent( biasIx );
// DLong bias=0;
BaseGDL* bias;
if(statusBias)
{
bias=e->GetKW( biasIx);
if( p0->Type() != bias->Type())
{
bias = bias->Convert2( p0->Type(), BaseGDL::COPY);
}
}
else bias=p1->New( 1,BaseGDL::ZERO);
/***********************************Parameter_Normalize**********************************/
static int normalIx = e->KeywordIx( "NORMALIZE");
bool normalize = e->KeywordPresent( normalIx);
/***********************************Parameter NAN****************************************/
static int nanIx = e->KeywordIx( "NAN");
bool doNan = e->KeywordPresent( nanIx);
/***********************************Parameter MISSING************************************/
static int missingIx = e->KeywordIx("MISSING");
bool doMissing = e->KeywordPresent( missingIx );
BaseGDL* missing;
if (p0->Type() != GDL_BYTE) {
if (doMissing) {
missing = e->GetKW(missingIx);
if (p0->Type() != missing->Type()) {
missing = missing->Convert2(p0->Type(), BaseGDL::COPY);
}
} else missing = p1->New(1, BaseGDL::ZERO);
} else {
if (doMissing) {
missing = e->GetKW(missingIx);
} else missing = p1->New(1, BaseGDL::ZERO);
missing = missing->Convert2(GDL_LONG, BaseGDL::COPY);
}
/***********************************Parameter INVALID************************************/
static int invalidIx = e->KeywordIx("INVALID");
bool doInvalid = e->KeywordPresent( invalidIx );
BaseGDL* invalid;
if (p0->Type() != GDL_BYTE) {
if (doInvalid) {
invalid = e->GetKW(invalidIx);
if (p0->Type() != invalid->Type()) {
invalid = invalid->Convert2(p0->Type(), BaseGDL::COPY);
}
} else invalid = p1->New(1, BaseGDL::ZERO);
} else {
if (doInvalid) {
invalid = e->GetKW(invalidIx);
} else invalid = p1->New(1, BaseGDL::ZERO);
invalid = invalid->Convert2(GDL_LONG, BaseGDL::COPY);
}
if (!doNan && !doInvalid) doMissing=false;
if (!doMissing && (p0->Type()==GDL_FLOAT ||p0->Type()==GDL_COMPLEX))
missing = SysVar::Values()->GetTag(SysVar::Values()->Desc()->TagIndex("F_NAN"), 0);
if (!doMissing && (p0->Type()==GDL_DOUBLE ||p0->Type()==GDL_COMPLEXDBL))
missing = SysVar::Values()->GetTag(SysVar::Values()->Desc()->TagIndex("D_NAN"), 0);
return p0->Convol( p1, scale, bias, center, normalize, edgeMode, doNan, missing, doMissing, invalid,doInvalid);
} //end of convol_fun
BaseGDL* _GDL_OBJECT_OverloadBracketsRightSide( EnvUDT* e)
{
// // debug/check
// std::cout << "_GDL_OBJECT_OverloadBracketsRightSide called" << std::endl;
SizeT nParam = e->NParam(); // number of parameters actually given
// int envSize = e->EnvSize(); // number of parameters + keywords 'e' (pro) has defined
if( nParam < 3) // consider implicit SELF
ThrowFromInternalUDSub( e, "At least 2 parameters are needed: ISRANGE, SUB1 [, ...].");
// default behavior: Exact like scalar indexing
BaseGDL* isRange = e->GetKW(1);
if( isRange == NULL)
ThrowFromInternalUDSub( e, "Parameter 1 (ISRANGE) is undefined.");
if( isRange->Rank() == 0)
ThrowFromInternalUDSub( e, "Parameter 1 (ISRANGE) must be an array in this context: " + e->Caller()->GetString(e->GetKW(1)));
SizeT nIsRange = isRange->N_Elements();
if( nIsRange > (nParam - 2)) //- SELF and ISRANGE
ThrowFromInternalUDSub( e, "Parameter 1 (ISRANGE) must have "+i2s(nParam-2)+" elements.");
Guard<DLongGDL> isRangeLongGuard;
DLongGDL* isRangeLong;
if( isRange->Type() == GDL_LONG)
isRangeLong = static_cast<DLongGDL*>( isRange);
else
{
try{
isRangeLong = static_cast<DLongGDL*>( isRange->Convert2( GDL_LONG, BaseGDL::COPY));
}
catch( GDLException& ex)
{
ThrowFromInternalUDSub( e, ex.ANTLRException::getMessage());
}
isRangeLongGuard.Reset( isRangeLong);
}
ArrayIndexVectorT ixList;
// IxExprListT exprList;
try {
for( int p=0; p<nIsRange; ++p)
{
BaseGDL* parX = e->GetKW( p + 2); // implicit SELF, ISRANGE, par1..par8
if( parX == NULL)
ThrowFromInternalUDSub( e, "Parameter is undefined: " + e->Caller()->GetString(e->GetKW( p + 2)));
DLong isRangeX = (*isRangeLong)[p];
if( isRangeX != 0 && isRangeX != 1)
{
ThrowFromInternalUDSub( e, "Value of parameter 1 (ISRANGE["+i2s(p)+"]) is out of allowed range.");
}
if( isRangeX == 1)
{
if( parX->N_Elements() != 3)
{
ThrowFromInternalUDSub( e, "Range vector must have 3 elements: " + e->Caller()->GetString(e->GetKW( p + 2)));
}
DLongGDL* parXLong;
Guard<DLongGDL> parXLongGuard;
if( parX->Type() != GDL_LONG)
{
try{
parXLong = static_cast<DLongGDL*>( parX->Convert2( GDL_LONG, BaseGDL::COPY));
parXLongGuard.Reset( parXLong);
}
catch( GDLException& ex)
{
ThrowFromInternalUDSub( e, ex.ANTLRException::getMessage());
}
}
else
{
parXLong = static_cast<DLongGDL*>( parX);
}
// negative end ix is fine -> CArrayIndexRangeS can handle [b:*:s] ([b,-1,s])
ixList.push_back(new CArrayIndexRangeS( (*parXLong)[0], (*parXLong)[1], (*parXLong)[2]));
}
else // non-range
{
// ATTENTION: These two grab c1 (all others don't)
// a bit unclean, but for maximum efficiency
if( parX->Rank() == 0)
ixList.push_back( new CArrayIndexScalar( parX->Dup()));
else
ixList.push_back( new CArrayIndexIndexed( parX->Dup()));
}
} // for
}
catch( GDLException& ex)
{
ixList.Destruct(); // ixList is not valid afterwards, but as we throw this is ok
throw ex;
}
ArrayIndexListT* aL;
MakeArrayIndex( &ixList, &aL, NULL); // important to get the non-NoAssoc ArrayIndexListT
// because only they clean up ixList on destruction
Guard< ArrayIndexListT> aLGuard( aL);
IxExprListT ixL;
return aL->Index( e->GetKW( 0), ixL); // index SELF
}
void print_os( ostream* os, EnvT* e, int parOffset, SizeT width)
{
// FORMAT keyword
if( e->GetKW( 0) != NULL)
{
DString fmtString;
e->AssureScalarKW<DStringGDL>( 0, fmtString);
if( fmtString != "")
{
try {
RefFMTNode fmtAST = GetFMTAST( fmtString);
#ifdef GDL_DEBUG
antlr::print_tree pt;
cout << "Format parser output:" << endl;
pt.pr_tree(static_cast<antlr::RefAST>(fmtAST));
cout << "Format Parser end." << endl;
#endif
// formatted output ignores WIDTH
FMTOut Formatter( fmtAST, os, e, parOffset);
return;
}
catch( antlr::ANTLRException& ex)
{
e->Throw( ex.getMessage());
}
}
}
//else // default-format output
{
int nParam = e->NParam();
if( nParam == parOffset)
{
(*os) << endl;
return;
}
BaseGDL* par;
bool lastParScalar = false;
BaseGDL* parOffsetPar = e->GetPar( parOffset);
bool anyArrayBefore = false;
if( parOffsetPar != NULL)
anyArrayBefore = parOffsetPar->Rank() > 0;
SizeT actPos = 0;
for( SizeT i=parOffset; i<nParam; i++)
{
if( i > parOffset) lastParScalar = /*par->Type() == GDL_STRING &&*/ par->Scalar();
par=e->GetPar( i);
if( par == NULL) // allowed here: NullGDL::GetSingleInstance())
e->Throw("Variable is undefined: "+e->GetParString( i));
if (lastParScalar && anyArrayBefore && par->Rank() != 0) (*os) << endl; // e.g. print,[1],1,[1]
anyArrayBefore |= par->Rank() != 0;
par->ToStream( *os, width, &actPos);
// debug
// (*os) << flush;
}
bool singleNullChar = (par->Type() == GDL_STRING &&
!lastParScalar &&
(nParam-parOffset)>1 &&
(*static_cast<DStringGDL*>(par))[0] == "");
// }
if( (par->Dim().Rank() == 0 && !singleNullChar) || par->Type() == GDL_STRUCT)
{
(*os) << endl;
}
}
}
ArrayIndexT* Dup() const
{
return new CArrayIndexIndexed( rawData->Dup(), strictArrSubs);
}
BaseGDL* OverloadIndexNew()
{
assert( rawData != NULL);
return rawData->Dup();
}
BaseGDL* OverloadIndexNew()
{
BaseGDL* v = varPtr->Data();
if( v == NULL) return NULL;
return v->Dup();
}
BaseGDL* rk4_fun(EnvT* e)
{
SizeT nParam = e->NParam();
if( nParam != 5)
e->Throw(" Invalid Number of arguments in RK4 ");
//----------------------------- ACQUISITION DES PARAMETRES ------------------//
//"Y" input array a vector of values for Y at X value
//DDoubleGDL* Yvals = new DDoubleGDL(e->GetParAs<DDoubleGDL>(0)->N_Elements(),BaseGDL::NOZERO);
DDoubleGDL* Yvals = e->GetParAs<DDoubleGDL>(0);
if(e->GetParDefined(0)->Type() == GDL_COMPLEX || e->GetParDefined(0)->Type() == GDL_COMPLEXDBL)
cout<<" If RK4 is complex then only the real part is used for the computation "<< endl;
//"dydx" input value or array
//DDoubleGDL* dydxvals = new DDoubleGDL(e->GetParAs<DDoubleGDL>(1)->N_Elements(),BaseGDL::NOZERO);
DDoubleGDL* dydxvals = e->GetParAs<DDoubleGDL>(1);
if(e->GetParDefined(1)->Type() == GDL_COMPLEX || e->GetParDefined(1)->Type() == GDL_COMPLEXDBL)
cout<<" If RK4 is complex then only the real part is used for the computation "<< endl;
if(dydxvals->N_Elements()!=Yvals->N_Elements())e->Throw(" Y and DYDX dimensions have to match ");
// "X" input value
DDoubleGDL* X = e->GetParAs<DDoubleGDL>(2);
if(e->GetParDefined(2)->Type() == GDL_COMPLEX || e->GetParDefined(2)->Type() == GDL_COMPLEXDBL)
cout<<" If RK4 is complex then only the real part is used for the computation "<< endl;
// "H" input value
DDoubleGDL* H = e->GetParAs<DDoubleGDL>(3);
if(e->GetParDefined(3)->Type() == GDL_COMPLEX || e->GetParDefined(3)->Type() == GDL_COMPLEXDBL)
cout<<" If RK4 is complex then only the real part is used for the computation "<< endl;
// Differentiate User's Function string name
DStringGDL* init = e->GetParAs<DStringGDL>(4);
if(e->GetParDefined(4)->Type() != GDL_STRING )
e->Throw(" Fifth value must be a function name string ");
//-------------------------------- Allocation -----------------------------------//
BaseGDL *Steptwo,*Stepthree,*Stepfour;
SizeT i;
DDoubleGDL *HH,*H6,*XplusH,*Ytampon,*XH,*Yout,* dym,* dyt;
Ytampon = new DDoubleGDL(Yvals->Dim(),BaseGDL::NOZERO);
Yout = new DDoubleGDL(Yvals->Dim(),BaseGDL::NOZERO);
HH = new DDoubleGDL(H->Dim(),BaseGDL::NOZERO);
H6 = new DDoubleGDL(H->Dim(),BaseGDL::NOZERO);
XH = new DDoubleGDL(H->Dim(),BaseGDL::NOZERO);
BaseGDL* XHO=static_cast<BaseGDL*>(XH);
XplusH = new DDoubleGDL(H->Dim(),BaseGDL::NOZERO);
BaseGDL* XplusHO=static_cast<BaseGDL*>(XplusH);
dym= new DDoubleGDL(Yvals->Dim(),BaseGDL::NOZERO);
dyt= new DDoubleGDL(Yvals->Dim(),BaseGDL::NOZERO);
//-------------------------------- Init FIRST STEP -----------------------------------//
(*HH)[0]=(*H)[0]*0.50000;
(*H6)[0]=(*H)[0]/6.00000;
(*XH)[0] = (*X)[0] + (*HH)[0];
// marc: probably an error
// XplusH[0] = (*X)[0] + (*H)[0];
(*XplusH)[0] = (*X)[0] + (*H)[0];
//dym=static_cast<DDoubleGDL*>(dymO);
//dyt=static_cast<DDoubleGDL*>(dytO);
//---------------------------- Init Call function -------------------------------------//
DString RK_Diff;
e->AssureScalarPar<DStringGDL>( 4, RK_Diff);
// this is a function name -> convert to UPPERCASE
RK_Diff = StrUpCase( RK_Diff);
// first search library funcedures
int funIx=LibFunIx( RK_Diff);
StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());
if( funIx != -1)
{
e->Throw(" String function name is intrinsic function name please change it ");
}
else
{
// Search in user proc and function
funIx = GDLInterpreter::GetFunIx(RK_Diff );
//-----------------FIRST STEP-------------------//
for (i=0;i<Yvals->N_Elements();++i)
(*Ytampon)[i]=(*Yvals)[i]+(*HH)[0]*(*dydxvals)[i];
BaseGDL* Ytmp=static_cast<BaseGDL*>(Ytampon);
// 1st CALL to user function "differentiate"
PushNewEnvRK(e, funList[ funIx],&XHO,&Ytmp);
EnvUDT* newEnv = static_cast<EnvUDT*>(e->Interpreter()->CallStack().back());
StackGuard<EnvStackT> guard1 ( e->Interpreter()->CallStack());
BaseGDL* Steptwo = e->Interpreter()->call_fun(static_cast<DSubUD*>(newEnv->GetPro())->GetTree());
//Conversion BaseGDL*-> DDoubleGDL* in order to use the RK_Diff function result.
dyt= static_cast<DDoubleGDL*>(Steptwo->Convert2(GDL_DOUBLE,BaseGDL::CONVERT));
//-------------SECOND STEP-------------------//
for (i=0;i<Yvals->N_Elements();++i)
(*Ytampon)[i]=(*Yvals)[i]+(*HH)[0]*(*dyt)[i];
// 2nd CALL to user function "differentiate"
PushNewEnvRK(e, funList[ funIx],&XHO,&Ytmp);
StackGuard<EnvStackT> guard2 ( newEnv->Interpreter()->CallStack());
BaseGDL* Stepthree = e->Interpreter()->call_fun(static_cast<DSubUD*>(newEnv->GetPro())->GetTree());
//Conversion BaseGDL*-> DDoubleGDL* in order to use the RK_Diff function result.
dym = static_cast<DDoubleGDL*>(Stepthree->Convert2(GDL_DOUBLE,BaseGDL::CONVERT));
//--------------THIRD STEP-------------------//
for (i=0;i<Yvals->N_Elements();++i)
{
(*Ytampon)[i]=(*Yvals)[i]+ (*H)[0]*(*dym)[i];
(*dym)[i] += (*dyt)[i];
}
// 3rd CALL to user function "differentiate"
PushNewEnvRK(e, funList[ funIx],&XplusHO,&Ytmp);
StackGuard<EnvStackT> guard3 ( newEnv->Interpreter()->CallStack());
BaseGDL* Stepfour = e->Interpreter()->call_fun(static_cast<DSubUD*>(newEnv->GetPro())->GetTree());
dyt= static_cast<DDoubleGDL*>(Stepfour->Convert2(GDL_DOUBLE,BaseGDL::CONVERT));
//--------------FOURTH STEP-------------------//
for (i=0;i<Yvals->N_Elements();++i)
(*Yout)[i]= (*Yvals)[i] + (*H6)[0] * ( (*dydxvals)[i]+(*dyt)[i]+ 2.00000*(*dym)[i] );
static DInt doubleKWIx = e->KeywordIx("DOUBLE");
//if need, convert things back
if( !e->KeywordSet(doubleKWIx))
return Yout->Convert2(GDL_FLOAT,BaseGDL::CONVERT);
else
return Yout;
}
assert( false);
}// RK4_fun
