*/ #include <string.h> #include "api_scilab.h" #include "MALLOC.h" #include "gw_linear_algebra.h" #include "callFunctionFromGateway.h" /*--------------------------------------------------------------------------*/ static int C2F(intvoid)(char *fname, unsigned long fname_len) { return 0; } /*--------------------------------------------------------------------------*/ static gw_generic_table Tab[] = { {C2F(inthess), "hess"}, {C2F(intschur), "schur"}, {C2F(inteig), "spec"}, {C2F(intbdiagr), "bdiag"}, {C2F(intvoid), "xxxx"}, {C2F(intbalanc), "balanc"} }; /*--------------------------------------------------------------------------*/ int gw_linear_algebra(void) { Rhs = Max(0, Rhs); if (pvApiCtx == NULL) { pvApiCtx = (StrCtx*)MALLOC(sizeof(StrCtx)); }

/*--------------------------------------------------------------------------*/ int sci_ceil(char *fname, unsigned long fname_len) { static int id[6]; C2F(intceil)(id); return 0; }

/*--------------------------------------------------------------------------*/ int C2F(intlsq)(char *fname, unsigned long fname_len) { int *header1; int *header2; int CmplxA; int Cmplxb; int ret; int I2; /* lsq(A,b) */ if (GetType(1) != sci_matrix) { OverLoad(1); return 0; } if (GetType(2) != sci_matrix) { OverLoad(2); return 0; } header1 = (int *) GetData(1); header2 = (int *) GetData(2); CmplxA = header1[3]; Cmplxb = header2[3]; switch (CmplxA) { case REAL: switch (Cmplxb) { case REAL : /* A real, b real */ ret = C2F(intdgelsy)("lsq", 3L); break; case COMPLEX : /* A real, b complex */ C2F(complexify)((I2 = 1, &I2)); ret = C2F(intzgelsy)("lsq", 3L); break; default: break; } return 0; case COMPLEX : switch (Cmplxb) { case REAL : /* A complex, b real */ C2F(complexify)((I2 = 2, &I2)); ret = C2F(intzgelsy)("lsq", 3L); break; case COMPLEX : /* A complex, b complex */ ret = C2F(intzgelsy)("lsq", 3L); break; default: Scierror(999, _("%s: Wrong type for input argument #%d: Real or Complex matrix expected.\n"), fname, 2); break; } return 0; break; default : Scierror(999, _("%s: Wrong type for input argument #%d: Real or Complex matrix expected.\n"), fname, 1); return 0; break; } }

void CoolingTower::EvalProducts(CNodeEvalIndex & NEI) { switch (SolveMethod()) { case SM_Direct: { const int wi = H2OLiq(); const int si = H2OVap(); const int ioLiq = IOWithId_Self(ioid_Liq); const int ioVap = IOWithId_Self(ioid_Vap); const int ioLoss = IOWithId_Self(ioid_LiqLoss); const int ioDrift = IOWithId_Self(ioid_DriftLoss); SpConduit & Ql=*IOConduit(ioLiq); SpConduit & Qv=*IOConduit(ioVap); StkSpConduit QMix("Mix", chLINEID(), this); iCycles = Max(2L, iCycles); dLGRatio = Range(0.01, dLGRatio, 10.0); ClrCI(3); ClrCI(4); ClrCI(5); ClrCI(6); dDuty = 0.0; SigmaQInPMin(QMix(), som_ALL, Id_2_Mask(ioid_Feed)); Ql.QCopy(QMix()); Qv.QCopy(QMix()); const double QmWaterLiqIn = QMix().VMass[wi]; const double QmWaterVapIn = QMix().VMass[si]; const double QmVapIn = QMix().QMass(som_Gas); dQmIn = QMix().QMass(som_ALL); const flag HasFlw = (dQmIn>UsableMass); dTempKFeed = QMix().Temp(); const double TotHfAtFeedT_Before = QMix().totHf(som_ALL, dTempKFeed, QMix().Press()); //RB.EvalProducts(QMix); //EHX.EvalProducts(QMix); //double POut = AtmosPress(); //force outlet to Atmos P double POut = Std_P; //force outlet to Std_P //double AvgCellAgeY=AvgCellAge/(365.25*24.0*60.0*60.0); //double TimeSinceDescaleM=TimeSinceDescale/(365.25*24.0*60.0*60.0/12.0); //double RqdLiqTemp = AirWetBulbT + Approach + AvgCellAgeY*1.1 + TimeSinceDescaleM/12.0*4.0; double RqdLiqTemp = dAirWetBulbT + dApproachT; double T1 = QMix().Temp(); double T2 = RqdLiqTemp; dLossQm = 0.0; bool ValidData; switch (iMethod) { case CTM_Simple: ValidData = (RqdLiqTemp<T1); break; case CTM_Merkel: ValidData = (iMerkelCalcType==MCT_TOut ? (dAirWetBulbT<T1) : (RqdLiqTemp<T1)); break; } if (!HasFlw) ValidData = false; double RqdLiqTempUsed; if (ValidData) { m_VLE.SetHfInAtZero(QMix()); if (iMethod==CTM_Simple) { //const double h1 = QMix().totHf(); RqdLiqTempUsed = RqdLiqTemp; EvapFnd EF(QMix(), RqdLiqTempUsed, POut, m_VLE);//QMix().Press()); EF.SetTarget(QMix().totHf()); if (Valid(dEvapFrac)) { EF.SetEstimate(dEvapFrac, 1.0); //dEvapFrac = dNAN; } flag Ok = false; dMaxEvapFrac = Range(0.01, dMaxEvapFrac, 1.0); int iRet=EF.Start(0.0, dMaxEvapFrac); if (iRet==RF_EstimateOK) //estimate is good, solve not required { Ok = true; } else { if (iRet==RF_BadEstimate) iRet = EF.Start(0.0, dMaxEvapFrac); // Restart if (iRet==RF_OK) if (EF.Solve_Brent()==RF_OK) Ok = true; } dEvapFrac = EF.Result(); //use result regardless if (!Ok) { SigmaQInPMin(QMix(), som_ALL, Id_2_Mask(ioid_Feed)); m_VLE.SetSatPVapFrac(QMix(), dEvapFrac, 0); QMix().SetPress(POut); RqdLiqTempUsed = QMix().Temp(); } //const double h2 = QMix().totHf(); //dDuty = h1-h2; this gives 0 (as expected) //dDuty is zero because there is no heattransfer with the air } else { dAirCp = Max(0.000001, dAirCp); dAirWetBulbT = Range(MerkelTMn, dAirWetBulbT, MerkelTMx-10.0); if (T1<MerkelTMn || T1>MerkelTMx) { SetCI(6, true); T1 = Range(MerkelTMn, T1, MerkelTMx); } MerkelTempFnd Fnd(QMix(), *this, T1); if (iMerkelCalcType==MCT_KaVL) { if (T2<MerkelTMn || T2>MerkelTMx) { SetCI(5, true); T2 = Range(MerkelTMn, T2, MerkelTMx); RqdLiqTemp = T2; } dKaVL = Fnd.Function(T2); } else { Fnd.SetTarget(dKaVL); //Note that for high LG_Ratio (eg>1.0) then ApproachT is higher. double Mn = dAirWetBulbT+(T1-dAirWetBulbT)*0.005; const double Mx = dAirWetBulbT+(T1-dAirWetBulbT)*0.999;//T1-0.001; if (Valid(RqdLiqTemp) && RqdLiqTemp>Mn && RqdLiqTemp<Mx) { Fnd.SetEstimate(RqdLiqTemp, 1.0); //RqdLiqTemp = dNAN; } flag Ok = false; int iRet=Fnd.Start(Mn, Mx); if (iRet==RF_EstimateOK) //estimate is good, solve not required { Ok = true; } else { double KaVL_MnTest = Fnd.Function(Mn); if (KaVL_MnTest<0.0) { //Crude fix to find min temp that doesn't cause KaV/L to be negative... double fr = 0.01; while (KaVL_MnTest<0.0 && fr<0.9) { Mn = dAirWetBulbT+(T1-dAirWetBulbT)*fr; KaVL_MnTest = Fnd.Function(Mn); fr += 0.01; } iRet = Fnd.Start(Mn, Mx); // Restart } if (iRet==RF_OK) if (Fnd.Solve_Brent()==RF_OK) Ok = true; } RqdLiqTemp = Fnd.Result(); //use result regardless T2 = RqdLiqTemp; if (!Ok) { const double KaVL_Calc = Fnd.Function(T2); SetCI(3, fabs(KaVL_Calc-dKaVL)>1.0e-6); } dApproachT = RqdLiqTemp - dAirWetBulbT; } dEvapFactor = Min(dEvapFactor, 0.1); //prevent user from puting a silly large number for this dEvapLossQm = dQmIn * dEvapFactor * (C2F(T1)-C2F(T2));//Evaporation Loss: WLe = Wc * EvapFactor * dT dEvapLossQm = Min(dEvapLossQm, QmWaterLiqIn); //limit the amount that can be evaporated RqdLiqTempUsed = RqdLiqTemp; dEvapFrac = Min(dMaxEvapFrac, (dEvapLossQm+QmWaterVapIn)/GTZ(QmWaterLiqIn+QmWaterVapIn)); const double h1 = QMix().totHf(); m_VLE.SetSatPVapFrac(QMix(), dEvapFrac, 0); QMix().SetPress(POut); QMix().SetTemp(RqdLiqTempUsed); const double h2 = QMix().totHf(); dDuty = h1-h2; //dAirEnthOut = AirEnth(T2); dAirEnthOut = Fnd.h2 / 0.430210432; //convert from Btu/lb to kJ/kg dAirQmIn = dQmIn/dLGRatio; dAirTRise = dDuty/GTZ(dAirQmIn)/dAirCp; dAirTOut = dAirDryBulbT + dAirTRise; dAirMixQm = dAirQmIn + dEvapLossQm; const double EvapLossCp = Qv.msCp(); dAirMixCp = dAirQmIn/GTZ(dAirMixQm)*dAirCp + dEvapLossQm/GTZ(dAirMixQm)*EvapLossCp; dAirMixT = dAirQmIn/GTZ(dAirMixQm)*dAirTOut + dEvapLossQm/GTZ(dAirMixQm)*T2; } double QmWaterVapOut = QMix().VMass[si]; dQmWaterEvap = Max(0.0, QmWaterVapOut - QmWaterVapIn); if (iMethod==CTM_Simple) dEvapLossQm=dQmWaterEvap; switch (iLossMethod) { case WLM_None: dDriftLossQm = 0.0; dBlowdownLossQm = 0.0; dLossQm = 0.0; break; case WLM_Frac: dRqdDriftLossFrac = Range(0.0, dRqdDriftLossFrac, 1.0); dRqdLossFrac = Range(0.0, dRqdLossFrac, 0.9); dLossQm = dQmIn * dRqdLossFrac; dDriftLossQm = dLossQm * dRqdDriftLossFrac; dBlowdownLossQm = dLossQm - dDriftLossQm; break; case WLM_Qm: dRqdDriftLossFrac = Range(0.0, dRqdDriftLossFrac, 1.0); dLossQm = dRqdLossQm; dDriftLossQm = dLossQm * dRqdDriftLossFrac; dBlowdownLossQm = dLossQm - dDriftLossQm; break; case WLM_DriftBlowdown: dDriftLossQm = dQmIn * dDriftLossFrac;//Drift Loss: WLd = % of water flow dBlowdownLossQm = dEvapLossQm/(iCycles-1);//Blowdown Loss: WLb = WLe / (cycles - 1) dLossQm = dDriftLossQm+dBlowdownLossQm; break; } if (dLossQm>dQmIn-dEvapLossQm-QmVapIn) { SetCI(4, true); dLossQm = dQmIn-dEvapLossQm-QmVapIn; } m_VLE.AddHfOutAtZero(QMix()); } else { RqdLiqTempUsed = T1; dEvapFrac = 0.0; dLossQm = 0.0; dDriftLossQm = 0.0; dBlowdownLossQm = 0.0; dEvapLossQm = 0.0; dQmWaterEvap = 0.0; //if (iMethod==CTM_Merkel) { dAirEnthOut = TotHfAtFeedT_Before / 0.430210432; //convert from Btu/lb to kJ/kg dAirQmIn = 0.0; dAirTRise = 0.0; dAirTOut = dTempKFeed; dAirMixQm = 0.0; dAirMixCp = 0.0; dAirMixT = dTempKFeed; } } //QMix.ChangeModel(&SMSteamClass); const double TotHfAtFeedT_After = QMix().totHf(som_ALL, dTempKFeed, QMix().Press()); Qv.QSetF(QMix(), som_Gas, 1.0); Qv.SetPress(POut); Qv.SetTemp(RqdLiqTempUsed); const double Qsl = QMix().QMass(som_SL); if (ioLoss<0) { if (ioDrift<0) { Ql.QSetF(QMix(), som_SL, 1.0); Ql.SetPress(POut); Ql.SetTemp(RqdLiqTempUsed); } else { SpConduit & Qdrift=*IOConduit(ioDrift); const double f = dDriftLossQm/GTZ(Qsl); Ql.QSetF(QMix(), som_SL, 1.0-f); Ql.SetPress(POut); Ql.SetTemp(RqdLiqTempUsed); Qdrift.QCopy(QMix()); Qdrift.QSetF(QMix(), som_SL, f); Qdrift.SetPress(POut); Qdrift.SetTemp(RqdLiqTempUsed); } } else { SpConduit & Qloss=*IOConduit(ioLoss); const double f = dLossQm/GTZ(Qsl); Ql.QSetF(QMix(), som_SL, 1.0-f); Ql.SetPress(POut); Ql.SetTemp(RqdLiqTempUsed); if (ioDrift<0) { Qloss.QCopy(QMix()); Qloss.QSetF(QMix(), som_SL, f); Qloss.SetPress(POut); Qloss.SetTemp(RqdLiqTempUsed); } else { const double fd = dDriftLossQm/GTZ(Qsl); const double fl = f - fd; SpConduit & Qdrift=*IOConduit(ioDrift); Qdrift.QCopy(QMix()); Qdrift.QSetF(QMix(), som_SL, fd); Qdrift.SetPress(POut); Qdrift.SetTemp(RqdLiqTempUsed); Qloss.QCopy(QMix()); Qloss.QSetF(QMix(), som_SL, fl); Qloss.SetPress(POut); Qloss.SetTemp(RqdLiqTempUsed); } } //results... dTotalLossQm = dLossQm+dEvapLossQm; dHeatFlow = TotHfAtFeedT_After - TotHfAtFeedT_Before; //what exactly is this??? dFinalP = Ql.Press(); dFinalT = Ql.Temp(); dTempDrop = T1 - dFinalT; SetCI(1, HasFlw && RqdLiqTemp>T1); SetCI(2, HasFlw && RqdLiqTempUsed>RqdLiqTemp); break; } default: MN_Surge::EvalProducts(NEI); } }

/*--------------------------------------------------------------------------*/ fscanfMatResult *fscanfMat(char *filename, char *format, char *separator, BOOL asDouble) { int fd = 0; int f_swap = 0; double res = 0.0; int errMOPEN = MOPEN_INVALID_STATUS; double dErrClose = 0.; int errMGETL = MGETL_ERROR; int i = 0; int nbLinesTextDetected = 0; int nbColumns = 0; int nbRows = 0; fscanfMatResult *resultFscanfMat = NULL; char **lines = NULL; int nblines = 0; double *dValues = NULL; if ((filename == NULL) || (format == NULL) || (separator == NULL)) { return NULL; } if (!checkFscanfMatFormat(format)) { resultFscanfMat = (fscanfMatResult*)(MALLOC(sizeof(fscanfMatResult))); if (resultFscanfMat) { resultFscanfMat->err = FSCANFMAT_FORMAT_ERROR; resultFscanfMat->m = 0; resultFscanfMat->n = 0; resultFscanfMat->sizeText = 0; resultFscanfMat->text = NULL; resultFscanfMat->values = NULL; } return resultFscanfMat; } C2F(mopen)(&fd, filename, READ_ONLY_TEXT_MODE, &f_swap, &res, &errMOPEN); if (errMOPEN != MOPEN_NO_ERROR) { resultFscanfMat = (fscanfMatResult*)(MALLOC(sizeof(fscanfMatResult))); if (resultFscanfMat) { resultFscanfMat->err = FSCANFMAT_MOPEN_ERROR; resultFscanfMat->m = 0; resultFscanfMat->n = 0; resultFscanfMat->sizeText = 0; resultFscanfMat->text = NULL; resultFscanfMat->values = NULL; } return resultFscanfMat; } lines = mgetl(fd, -1, &nblines, &errMGETL); C2F(mclose)(&fd, &dErrClose); if (errMGETL != MGETL_NO_ERROR) { resultFscanfMat = (fscanfMatResult*)(MALLOC(sizeof(fscanfMatResult))); if (resultFscanfMat) { resultFscanfMat->err = FSCANFMAT_READLINES_ERROR; resultFscanfMat->m = 0; resultFscanfMat->n = 0; resultFscanfMat->sizeText = 0; resultFscanfMat->text = NULL; resultFscanfMat->values = NULL; } return resultFscanfMat; } lines = removeEmptyLinesAtTheEnd(lines, &nblines); lines = removeTextLinesAtTheEnd(lines, &nblines, format, separator); nbLinesTextDetected = getNumbersLinesOfText(lines, nblines, format, separator); nbRows = nblines - nbLinesTextDetected; nbColumns = getNumbersColumnsInLines(lines, nblines, nbLinesTextDetected, format, separator); dValues = getDoubleValuesFromLines(lines, nblines, nbLinesTextDetected, format, separator, nbColumns, nbRows); if (dValues) { resultFscanfMat = (fscanfMatResult*)(MALLOC(sizeof(fscanfMatResult))); if (resultFscanfMat) { if (nbLinesTextDetected > 0) { if (lines) { for (i = nbLinesTextDetected; i < nblines; i++) { if (lines[i]) { FREE(lines[i]); lines[i] = NULL; } } } resultFscanfMat->text = lines; } else { freeArrayOfString(lines, nblines); resultFscanfMat->text = NULL; } resultFscanfMat->sizeText = nbLinesTextDetected; resultFscanfMat->m = nbRows; resultFscanfMat->n = nbColumns; resultFscanfMat->values = dValues; resultFscanfMat->err = FSCANFMAT_NO_ERROR; } else { freeArrayOfString(lines, nblines); } } else { freeArrayOfString(lines, nblines); if (nbColumns == 0 || nbRows == 0) { resultFscanfMat = (fscanfMatResult*)(MALLOC(sizeof(fscanfMatResult))); if (resultFscanfMat) { resultFscanfMat->err = FSCANFMAT_READLINES_ERROR; resultFscanfMat->m = 0; resultFscanfMat->n = 0; resultFscanfMat->sizeText = 0; resultFscanfMat->text = NULL; resultFscanfMat->values = NULL; } } } return resultFscanfMat; }

/*--------------------------------------------------------------------------*/ int sci_mseek(char *fname, unsigned long fname_len) { int m1 = 0, n1 = 0, l1 = 0; int m2 = 0, n2 = 0, l2 = 0; int m3 = 0, n3 = 0, l3 = 0; int err = 0; int fd = ALL_FILES_DESCRIPTOR; char *flag = NULL; Nbvars = 0; CheckRhs(1, 3); CheckLhs(1, 1); if (GetType(1) == sci_matrix) { GetRhsVar(1, MATRIX_OF_DOUBLE_DATATYPE, &m1, &n1, &l1); if (m1*n1 != 1) { Scierror(999, _("%s: Wrong size for input argument #%d: An integer expected.\n"), fname, 1); return 0; } } else { Scierror(999, _("%s: Wrong type for input argument #%d: An integer expected.\n"), fname, 1); return 0; } if ( Rhs >= 2) { if (GetType(2) == sci_matrix) { GetRhsVar(2, MATRIX_OF_INTEGER_DATATYPE, &m2, &n2, &l2); if (m2*n2 == 1) { fd = *istk(l2); } else { Scierror(999, _("%s: Wrong size for input argument #%d: An integer expected.\n"), fname, 2); } } else { Scierror(999, _("%s: Wrong type for input argument #%d: An integer expected.\n"), fname, 2); return 0; } } if ( Rhs >= 3) { GetRhsVar(3, STRING_DATATYPE, &m3, &n3, &l3); flag = cstk(l3); } else { flag = "set"; } C2F(mseek)(&fd, stk(l1), flag, &err); if (err > 0) { SciError(10000); return 0; } LhsVar(1) = 0; PutLhsVar(); return 0; }

/*--------------------------------------------------------------------------*/ int var2sci(void *x, int n, int m, int typ_var) { /************************************ * variables and constants d?inition ************************************/ /*counter and address variable declaration*/ int nm = 0, il = 0, l = 0, j = 0, i = 0, err = 0; /*define all type of accepted ptr */ SCSREAL_COP *x_d = NULL, *ptr_d = NULL; SCSINT8_COP *x_c = NULL, *ptr_c = NULL; SCSUINT8_COP *x_uc = NULL, *ptr_uc = NULL; SCSINT16_COP *x_s = NULL, *ptr_s = NULL; SCSUINT16_COP *x_us = NULL, *ptr_us = NULL; SCSINT_COP *x_i = NULL, *ptr_i = NULL; SCSUINT_COP *x_ui = NULL, *ptr_ui = NULL; SCSINT32_COP *x_l = NULL, *ptr_l = NULL; SCSUINT32_COP *x_ul = NULL, *ptr_ul = NULL; /* Check if the stack is not full */ if (Top >= Bot) { return 1; } else { Top = Top + 1; il = iadr(*Lstk(Top)); l = sadr(il + 4); } /* set number of double needed to store data */ if (typ_var == SCSREAL_N) { nm = n * m; /*double real matrix*/ } else if (typ_var == SCSCOMPLEX_N) { nm = n * m * 2; /*double real matrix*/ } else if (typ_var == SCSINT_N) { nm = (int)(ceil((n * m) / 2) + 1); /*int*/ } else if (typ_var == SCSINT8_N) { nm = (int)(ceil((n * m) / 8) + 1); /*int8*/ } else if (typ_var == SCSINT16_N) { nm = (int)(ceil((n * m) / 4) + 1); /*int16*/ } else if (typ_var == SCSINT32_N) { nm = (int)(ceil((n * m) / 2) + 1); /*int32*/ } else if (typ_var == SCSUINT_N) { nm = (int)(ceil((n * m) / 2) + 1); /*uint*/ } else if (typ_var == SCSUINT8_N) { nm = (int)(ceil((n * m) / 8) + 1); /*uint8*/ } else if (typ_var == SCSUINT16_N) { nm = (int)(ceil((n * m) / 4) + 1); /*uint16*/ } else if (typ_var == SCSUINT32_N) { nm = (int)(ceil((n * m) / 2) + 1); /*uint32*/ } else if (typ_var == SCSUNKNOW_N) { nm = n * m; /*arbitrary scilab object*/ } else { nm = n * m; /*double real matrix*/ } /*check if there is free space for new data*/ err = l + nm - *Lstk(Bot); if (err > 0) { return 2; } /************************** * store data on the stack *************************/ switch (typ_var) /*for each type of data*/ { case SCSREAL_N : /* set header */ *istk(il) = sci_matrix; /*double real matrix*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 0; x_d = (SCSREAL_COP *) x; ptr_d = (SCSREAL_COP *) stk(l); for (j = 0; j < m * n; j++) { ptr_d[j] = x_d[j]; } break; case SCSCOMPLEX_N : /* set header */ *istk(il) = 1; /*double complex matrix*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 1; x_d = (SCSCOMPLEX_COP *) x; ptr_d = (SCSCOMPLEX_COP *) stk(l); for (j = 0; j < 2 * m * n; j++) { ptr_d[j] = x_d[j]; } break; case SCSINT_N : /* set header */ *istk(il) = sci_ints; /*int*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 4; x_i = (SCSINT_COP *) x; for (j = 0; j < m * n; j++) { ptr_i = (SCSINT_COP *) istk(il + 4); ptr_i[j] = x_i[j]; } break; case SCSINT8_N : /* set header */ *istk(il) = sci_ints; /*int8*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 1; x_c = (SCSINT8_COP *) x; for (j = 0; j < m * n; j++) { ptr_c = (SCSINT8_COP *) istk(il + 4); ptr_c[j] = x_c[j]; } break; case SCSINT16_N : /* set header */ *istk(il) = sci_ints; /*int16*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 2; x_s = (SCSINT16_COP *) x; for (j = 0; j < m * n; j++) { ptr_s = (SCSINT16_COP *) istk(il + 4); ptr_s[j] = x_s[j]; } break; case SCSINT32_N : /* set header */ *istk(il) = sci_ints; /*int32*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 4; x_l = (SCSINT32_COP *) x; for (j = 0; j < m * n; j++) { ptr_l = (SCSINT32_COP *) istk(il + 4); ptr_l[j] = x_l[j]; } break; case SCSUINT_N : /* set header */ *istk(il) = sci_ints; /*uint*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 14; x_ui = (SCSUINT_COP *) x; for (j = 0; j < m * n; j++) { ptr_ui = (SCSUINT_COP *) istk(il + 4); ptr_ui[j] = x_ui[j]; } break; case SCSUINT8_N : /* set header */ *istk(il) = sci_ints; /*uint8*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 11; x_uc = (SCSUINT8_COP *) x; for (j = 0; j < m * n; j++) { ptr_uc = (SCSUINT8_COP *) istk(il + 4); ptr_uc[j] = x_uc[j]; } break; case SCSUINT16_N : /* set header */ *istk(il) = sci_ints; /*uint16*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 12; x_us = (SCSUINT16_COP *) x; for (j = 0; j < m * n; j++) { ptr_us = (SCSUINT16_COP *) istk(il + 4); ptr_us[j] = x_us[j]; } break; case SCSUINT32_N : /* set header */ *istk(il) = sci_ints; /*uint32*/ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 14; x_ul = (SCSUINT32_COP *) x; for (j = 0; j < m * n; j++) { ptr_ul = (SCSUINT32_COP *) istk(il + 4); ptr_ul[j] = x_ul[j]; } break; case SCSUNKNOW_N : x_d = (double *) x; C2F(unsfdcopy)(&nm, x_d, (j = 1, &j), stk(*Lstk(Top)), (i = 1, &i)); break; default : /* set header */ *istk(il) = sci_matrix; /* double by default */ *istk(il + 1) = n; *istk(il + 2) = m; *istk(il + 3) = 0; x_d = (double *) x; for (j = 0; j < m * n; j++) { ptr_d = (double *) stk(il + 4); ptr_d[j] = x_d[j]; } break; } /* set value in lstk */ *Lstk(Top + 1) = l + nm; return 0; }

/*--------------------------------------------------------------------------*/ types::Function::ReturnValue sci_rpem(types::typed_list &in, int _iRetCount, types::typed_list &out) { double* data = NULL; double* u = NULL; double* y = NULL; double* tstab = NULL; double* work = NULL; double* f = NULL; double* g = NULL; double v = 0; double eps = 0; double eps1 = 0; double lambda = 0.950l; double alpha = 0.990l; double beta = 0.01l; double kappa = 0.000l; double mu = 0.980l; double nu = 0.020l; double c = 1000.0l; int order = 0; int dimension = 0; int istab2 = 0; int u_length = 0; types::Double* dTheta = NULL; types::Double* dP = NULL; types::Double* dPhi = NULL; types::Double* dPsi = NULL; types::Double* dL = NULL; if (in.size() < 3 || in.size() > 6) { Scierror(77, _("%s: Wrong number of input argument(s): %d to %d expected.\n"), "rpem", 3, 6); return types::Function::Error; } /* arg1: w0 = list(theta, p, l, phi, psi) */ if ((in[0]->isList() == false) || in[0]->getAs<types::List>()->getSize() != 5) { Scierror(999, _("%s: Wrong type for input argument #%d: %d-element list expected.\n"), "rpem", 1, 5); return types::Function::Error; } types::List* w0 = in[0]->getAs<types::List>(); for (int i = 0; i < 5; i++) { if (!w0->get(i)->isDouble() || w0->get(i)->getAs<types::Double>()->isComplex()) { Scierror(77, _("%s: Wrong type for element %d of input argument #%d: A matrix of real expected.\n"), "rpem", i + 1, 1); return types::Function::Error; } types::Double* current = w0->get(i)->getAs<types::Double>(); switch (i) { case 0: /* theta: 3n real ranged row vector */ { if (current->getRows() != 1) { Scierror(77, _("%s: Wrong size for element %d of input argument #%d: A row vector expected.\n"), "rpem", i + 1, 1); return types::Function::Error; } if (current->getCols() % 3 != 0) { Scierror(77, _("%s: Wrong size for element %d of input argument #%d: Size must be multiple of %d.\n"), "rpem", i + 1, 1, 3); return types::Function::Error; } dimension = current->getCols(); order = dimension / 3; dTheta = new types::Double(1, dimension); dTheta->set(current->get()); } break; case 1: /* p: 3n x 3n real ranged matrix */ { if (current->getRows() != dimension || current->getCols() != dimension) { Scierror(77, _("%s: Wrong size for element %d of input argument #%d: A square matrix expected.\n"), "rpem", i + 1, 1); return types::Function::Error; } dP = new types::Double(dimension, dimension); dP->set(current->get()); } break; case 2: /* l: 3n real ranged row vector */ case 3: /* phi: 3n real ranged row vector */ case 4: /* psi: 3n real ranged row vector */ { if (current->getRows() != 1 || current->getCols() != dimension) { Scierror(77, _("%s: Wrong size for element %d of input argument #%d: Same sizes of element %d expected.\n"), "rpem", i + 1, 1, 1); return types::Function::Error; } } } } dL = new types::Double(1, dimension); dPhi = new types::Double(1, dimension); dPsi = new types::Double(1, dimension); dL->set(w0->get(2)->getAs<types::Double>()->get()); dPhi->set(w0->get(3)->getAs<types::Double>()->get()); dPsi->set(w0->get(4)->getAs<types::Double>()->get()); /* arg2: u0: real ranged row vector */ if ((in[1]->isDouble() == false) || in[1]->getAs<types::Double>()->getRows() != 1) { Scierror(999, _("%s: Wrong size for input argument #%d: A row vector expected.\n"), "rpem", 2); return types::Function::Error; } u = in[1]->getAs<types::Double>()->get(); u_length = in[1]->getAs<types::Double>()->getCols(); /* arg3: y0: real ranged row vector of same length as u0 */ if ((in[2]->isDouble() == false) || in[2]->getAs<types::Double>()->getRows() != 1) { Scierror(999, _("%s: Wrong size for input argument #%d: A row vector expected.\n"), "rpem", 3); return types::Function::Error; } if (in[2]->getAs<types::Double>()->getCols() != u_length) { Scierror(999, _("%s: Incompatible input arguments #%d and #%d: Same column dimensions expected.\n"), "rpem", 2, 3); return types::Function::Error; } y = in[2]->getAs<types::Double>()->get(); /* optional arguments */ switch (in.size()) { case 6: /* c */ { if ((in[5]->isDouble() == false) || !in[5]->getAs<types::Double>()->isScalar()) { Scierror(999, _("%s: Wrong size for input argument #%d: A scalar expected.\n"), "rpem", 6); return types::Function::Error; } c = in[5]->getAs<types::Double>()->get(0); } case 5: /* [kappa, mu, nu] */ { if ((in[4]->isDouble() == false) || (in[4]->getAs<types::Double>()->getRows() != 1) || (in[4]->getAs<types::Double>()->getCols() != 3)) { Scierror(999, _("%s: Wrong size for input argument #%d: A %d-by-%d matrix expected.\n"), "rpem", 5, 1, 3); return types::Function::Error; } data = in[4]->getAs<types::Double>()->get(); kappa = data[0]; mu = data[1]; nu = data[2]; } case 4: /* [lambda, alpha, beta] */ { if ((in[3]->isDouble() == false) || (in[3]->getAs<types::Double>()->getRows() != 1) || (in[3]->getAs<types::Double>()->getCols() != 3)) { Scierror(999, _("%s: Wrong size for input argument #%d: A %d-by-%d matrix expected.\n"), "rpem", 4, 1, 3); return types::Function::Error; } data = in[3]->getAs<types::Double>()->get(); lambda = data[0]; alpha = data[1]; beta = data[2]; } } /*** algorithm call ***/ /* references provided to justify allocation with code relying on it */ f = (double *) MALLOC((dimension) * sizeof(double)); /* rpem.f l.168 */ memset(f, 0x00, (dimension) * sizeof(double)); g = (double *) MALLOC((dimension) * sizeof(double)); /* rpem.f l.169 */ memset(g, 0x00, (dimension) * sizeof(double)); tstab = (double *) MALLOC((order + 1) * sizeof(double)); /* rpem.f l.105 */ memset(tstab, 0x00, (order + 1) * sizeof(double)); work = (double *) MALLOC((2 * order + 2) * sizeof(double)); /* nstabl.f */ memset(work, 0x00, (2 * order + 2) * sizeof(double)); /* (tip: bound variables to determine required memory: nk1 <= ordre + 1) */ for (int i = 1 ; i < u_length ; ++i) { C2F(rpem)( dTheta->get(), dP->get(), &order, &(u[i - 1]), &(y[i]), &lambda, &kappa, &c, &istab2, &v, &eps, &eps1, //output &dimension, dPhi->get(), dPsi->get(), tstab, work, //output f, g, dL->get()); lambda = alpha * lambda + beta; kappa = mu * kappa + nu; } FREE(work); FREE(tstab); FREE(g); FREE(f); /*** output formatting ***/ types::List* resultList = new types::List(); resultList->append(dTheta); resultList->append(dP); resultList->append(dL); resultList->append(dPhi); resultList->append(dPsi); out.push_back(resultList); if (_iRetCount == 2) { types::Double* dV = new types::Double(1, 1); dV->set(&v); out.push_back(dV); } return types::Function::OK; }

/*--------------------------------------------------------------------------*/ int C2F(sci_errclear)(char *fname,unsigned long fname_len) { Rhs = Max(0,Rhs); CheckRhs(0,2); CheckLhs(1,1); if (Rhs == 1) { SciErr sciErr; int *piAddressVarOne = NULL; sciErr = getVarAddressFromPosition(pvApiCtx, 1, &piAddressVarOne); if(sciErr.iErr) { printError(&sciErr, 0); Scierror(999, _("%s: Can not read input argument #%d.\n"), fname, 1); return 0; } if (isDoubleType(pvApiCtx, piAddressVarOne)) { double dValue = 0.; int iValue = 0; int iLastErrorValue = getInternalLastErrorValue(); if (!isScalar(pvApiCtx, piAddressVarOne)) { Scierror(999,_("%s: Wrong size for input argument #%d: A scalar expected.\n"), fname, 1); return 0; } getScalarDouble(pvApiCtx, piAddressVarOne, &dValue); iValue = (int)dValue; if ((double)iValue != dValue) { Scierror(999,_("%s: Wrong value for input argument #%d: An integer value expected.\n"), fname, 1); return 0; } if ((iValue == iLastErrorValue) || (iValue <= 0)) { /* clear fortran common error */ C2F(errgst).err2 = 0; /* clear last error buffer (C) */ clearInternalLastError(); } } else { Scierror(999,_("%s: Wrong type for input argument #%d: An integer value expected.\n"), fname, 1); return 0; } } else { /* clear fortran common error */ C2F(errgst).err2 = 0; /* clear last error buffer (C) */ clearInternalLastError(); } LhsVar(1) = 0; PutLhsVar(); return 0; }

/*--------------------------------------------------------------------------*/ static int zbeshg(double *x1r, double *x1i, double *alpha, int *kode, int *k, int *n, double *yr, double *yi, int *nz, double *wr, double *wi, int *ierr) { int iOne = 1; int iTwo = 2; double dNegOne = -1.; double nan = C2F(returnanan)(); int iVal = 0; int nn = 0; double xr = *x1r; double xi = *x1i; int intalpha = (int)(*alpha); /* extends cbesi for the case where alpha is negative */ if (ISNAN(xr) || ISNAN(xi) || ISNAN(*alpha)) { /* NaN case */ C2F(dset)(n, &nan, &yr[0], &iOne); C2F(dset)(n, &nan, &yi[0], &iOne); *ierr = 4; } else if (*alpha >= 0.) { C2F(zbesh)(&xr, &xi, alpha, kode, k, n, &yr[0], &yi[0], nz, ierr); if (*ierr == 1 || *ierr == 2 || *ierr >= 4) { C2F(dset)(n, &nan, &yr[0], &iOne); C2F(dset)(n, &nan, &yi[0], &iOne); } } else if (*alpha == (double)intalpha) { double a1 = 0.; /* alpha < 0 and int, */ /* transform to positive value of alpha */ if (*alpha - 1 + *n >= 0.) { /* 0 is between alpha and alpha+n */ a1 = 0.; /* Computing MIN */ nn = Min(*n, (int) (-(*alpha))); } else { a1 = -(*alpha - 1 + *n); nn = *n; } C2F(zbesh)(&xr, &xi, &a1, kode, k, n, &wr[0], &wi[0], nz, ierr); if (*ierr == 1 || *ierr == 2 || *ierr >= 4) { C2F(dset)(n, &nan, &yr[0], &iOne); C2F(dset)(n, &nan, &yi[0], &iOne); } else { if (*n > nn) { /* 0 is between alpha and alpha+n */ iVal = *n - nn; C2F(dcopy)(&iVal, &wr[0], &iOne, &yr[nn], &iOne); C2F(dcopy)(&iVal, &wi[0], &iOne, &yi[nn], &iOne); C2F(dcopy)(&nn, &wr[1], &iOne, &yr[0], &iOne); C2F(dcopy)(&nn, &wi[1], &iOne, &yi[0], &iOne); } else { /* alpha and alpha+n are negative */ C2F(dcopy)(n, &wr[0], &iOne, &yr[0], &iOne); C2F(dcopy)(n, &wi[0], &iOne, &yi[0], &iOne); } } iVal = (nn - (((int) fabs(*alpha) + 1) % 2) + 1) / 2; C2F(dscal)(&iVal, &dNegOne, &yr[((int) fabs(*alpha) + 1) % 2], &iTwo); C2F(dscal)(&iVal, &dNegOne, &yi[((int) fabs(*alpha) + 1) % 2], &iTwo); } else { int nz1 = 0; double a1 = 0.; /* first alpha is negative non int, transform to positive value of alpha */ if (*alpha - 1. + *n >= 0.) { /* 0 is between alpha and alpha+n */ nn = (int) (-(*alpha)) + 1; } else { nn = *n; } /* compute for negative value of alpha+k, transform problem for */ /* a1:a1+(nn-1) with a1 positive a1+k =abs(alpha+nn-k) */ a1 = -(*alpha - 1. + nn); C2F(zbesh)(&xr, &xi, &a1, kode, k, n, &wr[0], &wi[0], &nz1, ierr); *nz = Max(nz1, 0); if (*ierr == 0) { double a = cos(a1 * M_PI); double b = sin(a1 * M_PI); if (*k == 1) { C2F(wscal)(&nn, &a, &b, &wr[0], &wi[0], &iOne); } else { double dNegB = -b; C2F(wscal)(&nn, &a, &dNegB, &wr[0], &wi[0], &iOne); } /* change sign to take into account that sin((a1+k)*pi) and cos((a1+k)*pi) */ /* changes sign with k */ if (nn >= 2) { iVal = nn / 2; C2F(dscal)(&iVal, &dNegOne, &wr[1], &iTwo); C2F(dscal)(&iVal, &dNegOne, &wi[1], &iTwo); } } else if (*ierr == 1 || *ierr == 2 || *ierr >= 4) { C2F(dset)(&nn, &nan, &wr[0], &iOne); C2F(dset)(&nn, &nan, &wi[0], &iOne); } /* store the result in the correct order */ C2F(dcopy)(&nn, &wr[0], &iOne, &yr[0], &iOne); C2F(dcopy)(&nn, &wi[0], &iOne, &yi[0], &iOne); /* compute for positive value of alpha+k is any */ if (*n > nn) { int ier = 0; a1 = 1. - a1; iVal = *n - nn; C2F(zbesh)(&xr, &xi, &a1, kode, k, &iVal, &yr[nn], &yi[nn], nz, &ier); if (ier == 1 || ier == 2 || ier >= 4) { iVal = *n - nn; C2F(dset)(&iVal, &nan, &yr[nn], &iOne); C2F(dset)(&iVal, &nan, &yi[nn], &iOne); } *ierr = Max(*ierr, ier); } } return 0; }

/* contains negative values */ int zbeshv(double *xr, double *xi, int *nx, double *alpha, int *na, int *kode, int *k, double *yr, double *yi, double *wr, double *wi, int *ierr) { double eps = C2F(dlamch)("p", strlen("p")); int iOne = 1; int i = 0, j = 0, nz = 0; *ierr = 0; if (*na < 0) { /* element wise case x and alpha are supposed to have the same size */ for (i = 1; i <= *nx; ++i) { int ier = 0; zbeshg(&xr[i - 1], &xi[i - 1], &alpha[i - 1], kode, k, &iOne, &yr[i - 1], &yi[i - 1], &nz, &wr[1], &wi[0], &ier); *ierr = Max(*ierr, ier); } } else if (*na == 1) { for (i = 1; i <= *nx; ++i) { int ier = 0; zbeshg(&xr[i - 1], &xi[i - 1], &alpha[0], kode, k, &iOne, &yr[i - 1], &yi[i - 1], &nz, &wr[0], &wi[0], &ier); *ierr = Max(*ierr, ier); } } else { /* compute besselh(x(i),y(j)), i=1,nx,j=1,na */ double dTmp = 0; int n = 0; int l = 1; L5: n = 0; L10: ++n; j = l + n; if (j <= *na && (dTmp = alpha[j] + 1 - alpha[j - 1], fabs(dTmp)) <= eps) { goto L10; } for (i = 1; i <= *nx; ++i) { int ier = 0; zbeshg(&xr[i - 1], &xi[i - 1], &alpha[l - 1], kode, k, &n, &wr[0], &wi[0], &nz, &wr[*na], &wi[*na], &ier); *ierr = Max(*ierr, ier); C2F(dcopy)(&n, &wr[0], &iOne, &yr[(i + (l - 1) * *nx) - 1], nx); C2F(dcopy)(&n, &wi[0], &iOne, &yi[(i + (l - 1) * *nx) - 1], nx); } l = j; if (l <= *na) { goto L5; } } return 0; }

int C2F(intmsparse)(int *id) { /* System generated locals */ int I1; /* Local variables */ static int tops; static int I, l, m, n; static int ia, il, it, lr, lw, ilc, nel, ilr, iat, irc, lat, top0; static int kkk; if( Rhs==2) { return empty(); } --id; /* Function Body */ Rhs = Max(0,Rhs); top0 = Top + 1 - Rhs; tops = Top; lw = C2F(vstk).lstk[Top]; if (Lhs != 1) { SciError(41); return 0; } if (Rhs != 1) { SciError(39); return 0; } il = C2F(vstk).lstk[Top-1] + C2F(vstk).lstk[Top-1] - 1; if (*istk(il) == 5) { nel = *istk(il + 4); m = *istk(il+1); n = *istk(il + 2); it = *istk(il + 3); ilr = il + 5; ilc = ilr + m; I1 = ilr + m + nel; l = I1 / 2 + 1; ia = lw + lw - 1; iat = ia + m + 1; irc = iat + n + 1; I1 = irc + n + nel; lat = I1 / 2 + 1; lw = lat + nel * (it + 1); Err = lw - C2F(vstk).lstk[Bot-1]; if (Err > 0) { SciError(17); return 0; } *istk(ia) = 1; I1 = m; for (I = 1; I <= I1; ++I) { *istk(ia + I) = *istk(ia + I - 1) + *istk(ilr + I - 1); } if (it == 0) { C2F(dspt)(&m, &n, stk(l), &nel, istk(ilr), istk(ia ), stk(lat), istk(iat), istk(irc)); } else { C2F(wspt)(&m, &n, stk(l), stk(l + nel), & nel, istk(ilr), istk(ia), stk(lat), stk(lat + nel), istk(iat), istk(irc)); } *istk(il ) = 7; I1 = ilr + n + 1 + nel; lr = I1 / 2 + 1; I1 = n + 1; /* FD modif Jc -1 & Ir -1 C2F(icopy)(&I1, istk(iat ), &c1, istk(ilr ), &c1); C2F(icopy)(&nel, istk(irc + n ), &c1, istk(ilr + n+1), &c1); */ for (kkk=0; kkk<I1; ++kkk) *istk(ilr+kkk)=*istk(iat+kkk)-1; for (kkk=0; kkk<nel; ++kkk) *istk(ilr+n+1+kkk)=*istk(irc+n+kkk)-1; I1 = nel * (it + 1); C2F(unsfdcopy)(&I1, stk(lat ), &c1, stk(lr ), & c1); C2F(vstk).lstk[Top] = lr + nel * (it + 1); } else if (*istk(il ) == 7) { } else { SciError(44); return 0; } return 0; }

int C2F(intmfull)(int *id) { int I1, I2, I3; /* Local variables */ static int l, m, n; static int il, it, ls, lw, ilc, nel, ilr, ils, kkk; static int top0; /* Parameter adjustments */ --id; /* Function Body */ Rhs = Max(0,Rhs); top0 = Top + 1 - Rhs; lw = C2F(vstk).lstk[Top]; if (Rhs != 1) { SciError(39); return 0; } if (Lhs != 1) { SciError(41); return 0; } il = C2F(vstk).lstk[Top -1] + C2F(vstk).lstk[Top -1] - 1; nel = *istk(il + 4); m = *istk(il+1); n = *istk(il + 2); it = *istk(il + 3); ilr = il + 5; ilc = ilr + n + 1; I1 = ilc + nel; l = I1 / 2 + 1; I1 = il + 4; /* Computing MAX */ I3 = I1 / 2 + 1 + m * n * (it + 1); I2 = Max(I3,lw); ils = I2 + I2 - 1; I1 = ils + n + 1 + nel; ls = I1 / 2 + 1; lw = ls + nel * (it + 1); Err = lw - C2F(vstk).lstk[Bot-1]; if (Err > 0) { SciError(17); return 0; } I1 = n + 1 + nel; /* FD modif */ for (kkk=0; kkk<I1; ++kkk) *istk(ils+kkk)=*istk(ilr+kkk)+1; /* C2F(icopy)(&I1, istk(ilr ), &c1, istk(ils ), &c1); */ I1 = nel * (it + 1); C2F(unsfdcopy)(&I1, stk(l ), &c1, stk(ls ), &c1); *istk(il ) = 1; I1 = il + 4; l = I1 / 2 + 1; if (it == 0) { dmspful(&m, &n, stk(ls ), &nel, istk(ils ), stk(l )); } else { wmspful(&m, &n, stk(ls ), stk(ls + nel ), &nel,istk(ils ), stk(l ), stk(l + m *n )); } C2F(vstk).lstk[Top] = l + m * n * (it + 1); return 0; }

int C2F(intmspget)(int *id) { int I1, I2, I3; /* Local variables */ static int ilrs; static int ityp, j, l, m, n; static int j1_; static int nc, il, it, lv, lw; static double tv; static int ilc, nel, nelmax, ilr, lij, ilv, top0, kkk; /* Parameter adjustments */ --id; /* Function Body */ Rhs = Max(0,Rhs); top0 = Top + 1 - Rhs; lw = C2F(vstk).lstk[Top]; if (Rhs != 1) { SciError(39); return 0; } if (Lhs > 3) { SciError(41); return 0; } il = C2F(vstk).lstk[Top -1] + C2F(vstk).lstk[Top -1] - 1; ityp = *istk(il ); nelmax = *istk(il + 4); m = *istk(il+1); n = *istk(il + 2); it = *istk(il + 3); ilr = il + 5; nel = *istk(ilr + n); /* printf("mspelm: nelmax,nel %i %i\n", nelmax,nel); */ ilc = ilr + n + 1; I1 = ilc + nelmax; l = I1 / 2 + 1; if (nel == 0) { *istk(il ) = 1; *istk(il+1) = 0; *istk(il + 2) = 0; *istk(il + 3) = 0; I1 = il + 4; C2F(vstk).lstk[Top] = I1 / 2 + 1; if (Lhs >= 2) { ++Top; il = C2F(vstk).lstk[Top -1] + C2F(vstk).lstk[Top -1] - 1; *istk(il ) = 1; *istk(il+1) = 0; *istk(il + 2) = 0; *istk(il + 3) = 0; I1 = il + 4; C2F(vstk).lstk[Top] = I1 / 2 + 1; } if (Lhs == 3) { ++Top; il = C2F(vstk).lstk[Top -1] + C2F(vstk).lstk[Top -1] - 1; *istk(il ) = 1; *istk(il+1) = 1; *istk(il + 2) = 2; *istk(il + 3) = 0; I1 = il + 4; l = I1 / 2 + 1; *stk(l ) = (double) m; *stk(l+1) = (double) n; C2F(vstk).lstk[Top] = l + 2; } return 0; } I1 = il + 4; lij = I1 / 2 + 1; I1 = lij + (nel << 1); ilv = I1 + I1 - 1; I1 = ilv + 4; lv = I1 / 2 + 1; I2 = lw, I3 = lv + nel * (it + 1); I1 = Max(I2,I3); ilrs = I1 + I1 - 1; I1 = ilrs + n + 1 + nel; lw = I1 / 2 + 1; Err = lw - C2F(vstk).lstk[Bot -1]; if (Err > 0) { SciError(17); return 0; } I1 = n + nel + 1; /* FD 1ere colonne de ij = indices en C + 1 */ for (kkk=0; kkk<I1; ++kkk) *istk(ilrs+kkk)=*istk(ilr+kkk)+1; /* C2F(icopy)(&I1, istk(ilr ), &c1, istk(ilrs ), &c1); */ /* V */ if (l >= lv) { I1 = nel * (it + 1); /* printf("vvvvvvvvvvvvvvvvvv\n"); printf("%f\n",stk(l)); printf("%f\n",stk(l+1)); printf("%f\n",stk(l+2)); printf("%f\n",stk(l+3)); printf("vvvvvvvvvvvvvvvvvv\n"); */ C2F(unsfdcopy)(&I1, stk(l ), &c1, stk(lv ), &c1); } else { I1 = nel * (it + 1); /* printf("wwwwwwwwwwwwwww\n"); printf("%f\n",*stk(l)); printf("%f\n",*stk(l+1)); printf("%f\n",*stk(l+2)); printf("%f\n",*stk(l+3)); printf("wwwwwwwwwwwwwwwwwwww\n"); */ C2F(unsfdcopy)(&I1, stk(l ), &c_n1, stk(lv ), &c_n1); } C2F(int2db)(&nel, istk(ilrs + n+1), &c1, stk(lij), &c1); for (j = 1; j <= n; ++j) { nc = *istk(ilrs + j ) - *istk(ilrs + j - 1); j1_ = *istk(ilrs + j - 1) -1; tv = (double) j; C2F(dset)(&nc, &tv, stk(lij + nel + j1_ ), &c1); } /* ij */ *istk(il ) = 1; *istk(il+1) = nel; *istk(il + 2) = 2; *istk(il + 3) = 0; C2F(vstk).lstk[Top] = lij + (nel << 1); if (Lhs >= 2) { /* V */ ++Top; il = C2F(vstk).lstk[Top -1] + C2F(vstk).lstk[Top -1] - 1; *istk(il ) = 1; *istk(il+1) = nel; *istk(il + 2) = 1; *istk(il + 3) = it; C2F(vstk).lstk[Top] = lv + nel * (it + 1); } if (Lhs == 3) { /* mn */ ++Top; il = C2F(vstk).lstk[Top -1] + C2F(vstk).lstk[Top -1] - 1; *istk(il ) = 1; *istk(il+1) = 1; *istk(il + 2) = 2; *istk(il + 3) = 0; I1 = il + 4; l = I1 / 2 + 1; *stk(l ) = (double) m; *stk(l+1) = (double) n; C2F(vstk).lstk[Top] = l + 2; } return 0; }

/*--------------------------------------------------------------------------*/ int sci_fsolve(char *fname,unsigned long fname_len) { C2F(scisolv)(fname,fname_len); return 0; }

types::Function::ReturnValue sci_impl(types::typed_list &in, int _iRetCount, types::typed_list &out) { // Methode types::String* pStrType = NULL; const wchar_t * wcsType = L"lsoda"; int meth = 2;// default methode is stiff // y0 types::Double* pDblY0 = NULL; double* pdYData = NULL; // contain y0 following by all args data in list case. int sizeOfpdYData = 0; // Other input args types::Double* pDblYdot0 = NULL; types::Double* pDblT0 = NULL; types::Double* pDblT = NULL; types::Double* pDblRtol = NULL; types::Double* pDblAtol = NULL; types::Double* pDblW = NULL; types::Double* pDblIw = NULL; // Result types::Double* pDblYOut = NULL; // Indicate if the function is given. bool bFuncF = false; // res bool bFuncJac = false; // jac bool bFuncG = false; // adda int iPos = 0; // Position in types::typed_list in int maxord = 5; // maxord = 12 (if meth = 1) or 5 (if meth = 2) int sizeOfYSize = 1; int* YSize = NULL; // YSize(1) = size of y0, // YSize(n) = size of Args(n) in list case. C2F(eh0001).mesflg = 1; // flag to control printing of error messages in lapack routine. // 1 means print, 0 means no printing. C2F(eh0001).lunit = 6; // 6 = stdout int one = 1; // use in dcopy // error message catched std::wostringstream os; bool bCatch = false; // *** check the minimal number of input args. *** if (in.size() < 6 || in.size() > 12) { Scierror(77, _("%s: Wrong number of input argument(s): %d to %d expected.\n"), "impl", 6, 12); return types::Function::Error; } // *** check number of output args *** if (_iRetCount > 3 || _iRetCount == 2) { Scierror(78, _("%s: Wrong number of output argument(s): %d or %d expected.\n"), "impl", 1, 3); return types::Function::Error; } // *** Get the methode. *** if (in[0]->isString()) { pStrType = in[0]->getAs<types::String>(); wcsType = pStrType->get(0); iPos++; } if (iPos) { if (wcscmp(wcsType, L"adams") == 0) { meth = 1; maxord = 12; } else if (wcscmp(wcsType, L"stiff") == 0) { meth = 2; } else { Scierror(999, _("%s: Wrong value for input argument #%d: It must be one of the following strings: adams or stiff.\n"), "impl", 1); return types::Function::Error; } } // *** check type of input args and get it. *** // y0 if (in[iPos]->isDouble() == false) { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "impl", iPos + 1); return types::Function::Error; } pDblY0 = in[iPos]->getAs<types::Double>(); if (pDblY0->isComplex()) { Scierror(999, _("%s: Wrong type for input argument #%d: A real matrix expected.\n"), "impl", iPos + 1); return types::Function::Error; } if (pDblY0->getCols() != 1 && pDblY0->getRows() != 1) { Scierror(999, _("%s: Wrong type for input argument #%d: A real vector expected.\n"), "impl", iPos + 1); return types::Function::Error; } // ydot0 iPos++; if (in[iPos]->isDouble() == false) { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "impl", iPos + 1); return types::Function::Error; } pDblYdot0 = in[iPos]->getAs<types::Double>(); if (pDblYdot0->isComplex()) { Scierror(999, _("%s: Wrong type for input argument #%d: A real matrix expected.\n"), "impl", iPos + 1); return types::Function::Error; } if (pDblYdot0->getCols() != 1 && pDblYdot0->getRows() != 1) { Scierror(999, _("%s: Wrong type for input argument #%d: A real vector expected.\n"), "impl", iPos + 1); return types::Function::Error; } // t0 iPos++; if (in[iPos]->isDouble() == false) { Scierror(999, _("%s: Wrong type for input argument #%d: A scalar expected.\n"), "impl", iPos + 1); return types::Function::Error; } pDblT0 = in[iPos]->getAs<types::Double>(); if (pDblT0->isScalar() == false) { Scierror(999, _("%s: Wrong size for input argument #%d: A scalar expected.\n"), "impl", iPos + 1); return types::Function::Error; } // t iPos++; if (in[iPos]->isDouble() == false) { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "impl", iPos + 1); return types::Function::Error; } pDblT = in[iPos]->getAs<types::Double>(); // get next inputs DifferentialEquationFunctions deFunctionsManager(L"impl"); DifferentialEquation::addDifferentialEquationFunctions(&deFunctionsManager); YSize = (int*)malloc(sizeOfYSize * sizeof(int)); *YSize = pDblY0->getSize(); pdYData = (double*)malloc(pDblY0->getSize() * sizeof(double)); C2F(dcopy)(YSize, pDblY0->get(), &one, pdYData, &one); for (iPos++; iPos < in.size(); iPos++) { if (in[iPos]->isDouble()) { if (pDblAtol == NULL && bFuncF == false) { pDblAtol = in[iPos]->getAs<types::Double>(); if (pDblAtol->getSize() != pDblY0->getSize() && pDblAtol->isScalar() == false) { Scierror(267, _("%s: Arg %d and arg %d must have equal dimensions.\n"), "impl", pStrType ? 2 : 1, iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } else if (pDblRtol == NULL && bFuncF == false) { pDblRtol = in[iPos]->getAs<types::Double>(); if (pDblRtol->getSize() != pDblY0->getSize() && pDblRtol->isScalar() == false) { Scierror(267, _("%s: Arg %d and arg %d must have equal dimensions.\n"), "impl", pStrType ? 2 : 1, iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } else if (pDblW == NULL && bFuncG == true) { if (in.size() == iPos + 2) { if (in[iPos + 1]->isDouble() == false) { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "impl", iPos + 2); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } pDblW = in[iPos]->getAs<types::Double>(); pDblIw = in[iPos + 1]->getAs<types::Double>(); iPos++; } else { Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), "impl", iPos + 2); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } else { Scierror(999, _("%s: Wrong type for input argument #%d: A function expected.\n"), "impl", iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } else if (in[iPos]->isCallable()) { types::Callable* pCall = in[iPos]->getAs<types::Callable>(); if (bFuncF == false) { deFunctionsManager.setFFunction(pCall); bFuncF = true; } else if (bFuncG == false) { deFunctionsManager.setGFunction(pCall); bFuncG = true; } else if (bFuncJac == false) { deFunctionsManager.setJacFunction(pCall); bFuncJac = true; } else { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "impl", iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } else if (in[iPos]->isString()) { types::String* pStr = in[iPos]->getAs<types::String>(); bool bOK = false; if (bFuncF == false) { bOK = deFunctionsManager.setFFunction(pStr); bFuncF = true; } else if (bFuncG == false) { bOK = deFunctionsManager.setGFunction(pStr); bFuncG = true; } else if (bFuncJac == false) { bOK = deFunctionsManager.setJacFunction(pStr); bFuncJac = true; } else { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "impl", iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } if (bOK == false) { char* pst = wide_string_to_UTF8(pStr->get(0)); Scierror(50, _("%s: Subroutine not found: %s\n"), "impl", pst); FREE(pst); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } else if (in[iPos]->isList()) { types::List* pList = in[iPos]->getAs<types::List>(); if (pList->getSize() == 0) { Scierror(50, _("%s: Argument #%d: Subroutine not found in list: %s\n"), "impl", iPos + 1, "(string empty)"); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } if (bFuncF && bFuncG && bFuncJac) { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), "impl", iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } if (pList->get(0)->isString()) { types::String* pStr = pList->get(0)->getAs<types::String>(); bool bOK = false; if (bFuncF == false) { bFuncF = true; bOK = deFunctionsManager.setFFunction(pStr); sizeOfpdYData = *YSize; } else if (bFuncG == false) { bFuncG = true; bOK = deFunctionsManager.setGFunction(pStr); if (sizeOfpdYData == 0) { sizeOfpdYData = *YSize; } } else if (bFuncJac == false) { bFuncJac = true; bOK = deFunctionsManager.setJacFunction(pStr); if (sizeOfpdYData == 0) { sizeOfpdYData = *YSize; } } if (bOK == false) { char* pst = wide_string_to_UTF8(pStr->get(0)); Scierror(50, _("%s: Argument #%d: Subroutine not found in list: %s\n"), "impl", iPos + 1, pst); FREE(pst); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } int* sizeTemp = YSize; int totalSize = sizeOfpdYData; YSize = (int*)malloc((sizeOfYSize + pList->getSize() - 1) * sizeof(int)); memcpy(YSize, sizeTemp, sizeOfYSize * sizeof(int)); std::vector<types::Double*> vpDbl; for (int iter = 0; iter < pList->getSize() - 1; iter++) { if (pList->get(iter + 1)->isDouble() == false) { Scierror(999, _("%s: Wrong type for input argument #%d: Argument %d in the list must be a matrix.\n"), "impl", iPos + 1, iter + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } vpDbl.push_back(pList->get(iter + 1)->getAs<types::Double>()); YSize[sizeOfYSize + iter] = vpDbl[iter]->getSize(); totalSize += YSize[sizeOfYSize + iter]; } double* pdYDataTemp = pdYData; pdYData = (double*)malloc(totalSize * sizeof(double)); C2F(dcopy)(&sizeOfpdYData, pdYDataTemp, &one, pdYData, &one); int position = sizeOfpdYData; for (int iter = 0; iter < pList->getSize() - 1; iter++) { C2F(dcopy)(&YSize[sizeOfYSize + iter], vpDbl[iter]->get(), &one, &pdYData[position], &one); position += vpDbl[iter]->getSize(); } vpDbl.clear(); sizeOfpdYData = totalSize; sizeOfYSize += pList->getSize() - 1; free(pdYDataTemp); free(sizeTemp); } else if (pList->get(0)->isCallable()) { if (bFuncF == false) { bFuncF = true; deFunctionsManager.setFFunction(pList->get(0)->getAs<types::Callable>()); for (int iter = 1; iter < pList->getSize(); iter++) { deFunctionsManager.setFArgs(pList->get(iter)->getAs<types::InternalType>()); } } else if (bFuncG == false) { bFuncG = true; deFunctionsManager.setGFunction(pList->get(0)->getAs<types::Callable>()); for (int iter = 1; iter < pList->getSize(); iter++) { deFunctionsManager.setGArgs(pList->get(iter)->getAs<types::InternalType>()); } } else if (bFuncJac == false) { bFuncJac = true; deFunctionsManager.setJacFunction(pList->get(0)->getAs<types::Callable>()); for (int iter = 1; iter < pList->getSize(); iter++) { deFunctionsManager.setJacArgs(pList->get(iter)->getAs<types::InternalType>()); } } } else { Scierror(999, _("%s: Wrong type for input argument #%d: The first argument in the list must be a string or a function.\n"), "impl", iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } else { Scierror(999, _("%s: Wrong type for input argument #%d: A matrix or a function expected.\n"), "impl", iPos + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } } if (bFuncF == false) { Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), "impl", in.size() + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } if (bFuncG == false) { Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), "impl", in.size() + 1); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); return types::Function::Error; } // *** Initialization. *** double t0 = pDblT0->get(0); int itol = 1; int iopt = 0; int istate = 1; int itask = 1; int jt = bFuncJac ? 1 : 2; int jacType = 10 * meth + jt; pDblYOut = new types::Double(pDblY0->getRows(), pDblT->getSize()); // work tab double* rwork = NULL; int* iwork = NULL; int rworkSize = 0; int iworkSize = 0; // contain ls0001, lsa001 and eh0001 structures double* dStructTab = NULL; int* iStructTab = NULL; int dStructTabSize = 219; // number of double in ls0001 int iStructTabSize = 41; // number of int in ls0001 (39) + eh0001 (2) int rwSize = 0; // rwSize = dStructTab + rworkSize int iwSize = 0; // iwSize = iStructTab + iworkSize // structures used by lsoda and lsode double* ls0001d = &(C2F(ls0001).tret); int* ls0001i = &(C2F(ls0001).illin); int* eh0001i = &(C2F(eh0001).mesflg); //compute itol and set the tolerances rtol and atol. double* rtol = NULL; double* atol = NULL; if (pDblRtol) { if (pDblRtol->isScalar()) { rtol = (double*)malloc(sizeof(double)); *rtol = pDblRtol->get(0); } else { rtol = pDblRtol->get(); itol += 2; } } else { rtol = (double*)malloc(sizeof(double)); *rtol = 1.e-9; } if (pDblAtol) { if (pDblAtol->isScalar()) { atol = (double*)malloc(sizeof(double)); *atol = pDblAtol->get(0); } else { atol = pDblAtol->get(); itol ++; } } else { atol = (double*)malloc(sizeof(double)); *atol = 1.e-7; } // Compute rwork, iwork size. // Create them. int nyh = (*YSize); if (pDblW) // structure ls0001 have been restored. { nyh = C2F(ls0001).nyh; } rworkSize = 20 + nyh * (maxord + 1) + 3 * *YSize + *YSize **YSize + 2; iworkSize = 20 + *YSize; rwSize = rworkSize + dStructTabSize; iwSize = iworkSize + iStructTabSize; rwork = (double*)malloc(rworkSize * sizeof(double)); iwork = (int*)malloc(iworkSize * sizeof(int)); if (pDblW && pDblIw) { if (pDblW->getSize() != rwSize || pDblIw->getSize() != iwSize) { Scierror(9999, _("%s: Wrong size for w and iw: w = %d and iw = %d expected.\n"), "impl", rwSize, iwSize); DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); free(rwork); free(iwork); if (itol == 1 || itol == 3) { free(atol); } if (itol < 3) { free(rtol); } return types::Function::Error; } istate = 2; // 1 means this is the first call | 2 means this is not the first call // restore rwork from pDblW C2F(dcopy)(&rworkSize, pDblW->get(), &one, rwork, &one); // restore iwork from pDblIw iStructTab = (int*)malloc(iStructTabSize * sizeof(int)); for (int i = 0; i < iworkSize; i++) { iwork[i] = (int)pDblIw->get(i); } //restore ls0001d from pDblW C2F(dcopy)(&dStructTabSize, pDblW->get() + rworkSize, &one, ls0001d, &one); //restore ls0001i from pDblIw for (int i = 0; i < iStructTabSize; i++) { iStructTab[i] = (int)pDblIw->get(i + iworkSize); } memcpy(ls0001i, iStructTab, 39 * sizeof(int)); } // *** Perform operation. *** int err = 0; for (int i = 0; i < pDblT->getSize(); i++) { double t = pDblT->get(i); try { C2F(lsodi)(impl_f, impl_g, impl_jac, YSize, pdYData, pDblYdot0->get(), &t0, &t, &itol, rtol, atol, &itask, &istate, &iopt, rwork, &rworkSize, iwork, &iworkSize, &jacType); // check error if (istate == 3) { sciprint(_("The user-supplied subroutine res signalled lsodi to halt the integration and return (ires=2). Execution of the external function has failed.\n")); err = 1; Scierror(999, _("%s: %s exit with state %d.\n"), "impl", "lsodi", istate); } else { err = checkOdeError(meth, istate); if (err == 1) { Scierror(999, _("%s: %s exit with state %d.\n"), "impl", "lsodi", istate); } } } catch (ast::InternalError &ie) { os << ie.GetErrorMessage(); bCatch = true; err = 1; } if (err == 1) { DifferentialEquation::removeDifferentialEquationFunctions(); free(pdYData); free(YSize); free(rwork); free(iwork); if (iStructTab) { free(iStructTab); } if (itol == 1 || itol == 3) { free(atol); } if (itol < 3) { free(rtol); } if (bCatch) { wchar_t szError[bsiz]; os_swprintf(szError, bsiz, _W("%s: An error occured in '%s' subroutine.\n").c_str(), "impl", "lsodi"); os << szError; throw ast::InternalError(os.str()); } return types::Function::Error; } for (int j = 0; j < *YSize; j++) { pDblYOut->set(i * (*YSize) + j, pdYData[j]); } } if (_iRetCount > 2) //save ls0001 and eh0001 following pDblW and pDblIw. { int dSize = 219; if (iStructTab == NULL) { iStructTab = (int*)malloc(iStructTabSize * sizeof(int)); } if (dStructTab == NULL) { dStructTab = (double*)malloc(dStructTabSize * sizeof(double)); } // save ls0001 C2F(dcopy)(&dSize, ls0001d, &one, dStructTab, &one); memcpy(iStructTab, ls0001i, 39 * sizeof(int)); // save eh0001 memcpy(&iStructTab[39], eh0001i, 2 * sizeof(int)); } // *** Return result in Scilab. *** out.push_back(pDblYOut); if (_iRetCount > 2) { types::Double* pDblWOut = new types::Double(1, rwSize); C2F(dcopy)(&rworkSize, rwork, &one, pDblWOut->get(), &one); C2F(dcopy)(&dStructTabSize, dStructTab, &one, pDblWOut->get() + rworkSize, &one); types::Double* pDblIwOut = new types::Double(1, iwSize); for (int i = 0; i < iworkSize; i++) { pDblIwOut->set(i, (double)iwork[i]); } for (int i = 0; i < iStructTabSize; i++) { pDblIwOut->set(iworkSize + i, (double)iStructTab[i]); } out.push_back(pDblWOut); out.push_back(pDblIwOut); } // *** free. *** if (itol == 1 || itol == 3) // atol is scalar { free(atol); } if (itol < 3) // rtol is scalar { free(rtol); } free(pdYData); free(YSize); free(rwork); free(iwork); if (dStructTab) { free(dStructTab); } if (iStructTab) { free(iStructTab); } DifferentialEquation::removeDifferentialEquationFunctions(); return types::Function::OK; }

{NULL, ""}, //spmin {sci_spmatrix, "spmatrix"}, {sci_spchol, "spchol"}, {sci_fadj2sp, "fadj2sp"}, {sci_spcompa, "spcompa"}, {sci_ordmmd, "ordmmd"}, {sci_blkfc1i, "blkfc1i"}, {sci_blkslvi, "blkslvi"}, {sci_inpnvi, "inpnvi"}, {sci_sfinit, "sfinit"}, {sci_symfcti, "symfcti"}, {sci_bfinit, "bfinit"}, {sci_msparse, "msparse"}, {sci_mspget, "mspget"}, {sci_mfull, "mfull"}, {C2F(scita2lpd), "ta2lpd"} }; /*--------------------------------------------------------------------------*/ int gw_sparse(void) { if (pvApiCtx == NULL) { pvApiCtx = (StrCtx*)MALLOC(sizeof(StrCtx)); } pvApiCtx->pstName = (char*)Tab[Fin - 1].name; callFunctionFromGateway(Tab, SIZE_CURRENT_GENERIC_TABLE(Tab)); return 0; } /*--------------------------------------------------------------------------*/

/*--------------------------------------------------------------------------*/ int cdffncI(char* fname, unsigned long l) { int m1 = 0, n1 = 0, l1 = 0, mDfd = 0, nDfd = 0, lDfd = 0, mDfn = 0, nDfn = 0, lDfn = 0, i = 0; double *Dfd = NULL, *Dfn = NULL; Nbvars = 0; CheckRhs(5, 6); CheckLhs(1, 2); GetRhsVar(1, STRING_DATATYPE, &m1, &n1, &l1); if ( strcmp(cstk(l1), "PQ") == 0) { static int callpos[6] = {4, 5, 0, 1, 2, 3}; GetRhsVar(3, MATRIX_OF_DOUBLE_DATATYPE, &mDfn, &nDfn, &lDfn); Dfn = stk(lDfn); for (i = 0; i < mDfn * nDfn; ++i) if ((int) Dfn[i] - Dfn[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 3); } GetRhsVar(4, MATRIX_OF_DOUBLE_DATATYPE, &mDfd, &nDfd, &lDfd); Dfd = stk(lDfd); for (i = 0; i < mDfd * nDfd; ++i) if ((int) Dfd[i] - Dfd[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 4); } 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}; GetRhsVar(2, MATRIX_OF_DOUBLE_DATATYPE, &mDfn, &nDfn, &lDfn); Dfn = stk(lDfn); for (i = 0; i < mDfn * nDfn; ++i) if ((int) Dfn[i] - Dfn[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 2); } GetRhsVar(3, MATRIX_OF_DOUBLE_DATATYPE, &mDfd, &nDfd, &lDfd); Dfd = stk(lDfd); for (i = 0; i < mDfd * nDfd; ++i) if ((int) Dfd[i] - Dfd[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 3); } 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}; GetRhsVar(2, MATRIX_OF_DOUBLE_DATATYPE, &mDfd, &nDfd, &lDfd); Dfd = stk(lDfd); for (i = 0; i < mDfd * nDfd; ++i) if ((int) Dfd[i] - Dfd[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 2); } 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}; GetRhsVar(6, MATRIX_OF_DOUBLE_DATATYPE, &mDfn, &nDfn, &lDfn); Dfn = stk(lDfn); for (i = 0; i < mDfn * nDfn; ++i) if ((int) Dfn[i] - Dfn[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 6); } 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}; GetRhsVar(5, MATRIX_OF_DOUBLE_DATATYPE, &mDfn, &nDfn, &lDfn); Dfn = stk(lDfn); for (i = 0; i < mDfn * nDfn; ++i) if ((int) Dfn[i] - Dfn[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 5); } GetRhsVar(6, MATRIX_OF_DOUBLE_DATATYPE, &mDfd, &nDfd, &lDfd); Dfd = stk(lDfd); for (i = 0; i < mDfd * nDfd; ++i) if ((int) Dfd[i] - Dfd[i] != 0) { sciprint(_("%s: Warning: using non integer values for argument #%d may lead to incorrect results.\n"), fname, 6); } CdfBase(fname, 5, 1, callpos, "Pnonc", _("P,Q,F,Dfn and Dfd"), 5, C2F(cdffnc), cdffncErr); } else { Scierror(999, _("%s: Wrong value for input argument #%d: '%s', '%s', '%s', '%s' or '%s' expected.\n"), fname, 1, "PQ", "F", "Dfn", "Dfd", "Pnonc"); } return 0; }

#define ARGS_fadda int*,double *,double *,int*,int*,double*,int* typedef void (*faddaf)(ARGS_fadda); #define ARGS_fj2 int *,double *,double *,double *,int *,int *,double*,int * typedef void (*fj2f)(ARGS_fj2); /**************** fres ***************/ extern void C2F(resid)(ARGS_fres); DIFFERENTIAL_EQUATIONS_IMPEXP void C2F(fres)(ARGS_fres); DIFFERENTIAL_EQUATIONS_IMPEXP void C2F(setfres)(char *name, int *rep); FTAB FTab_fres[] = { {"resid", (voidf) C2F(resid)}, {(char *) 0, (voidf) 0} }; /**************** fadda ***************/ extern void C2F(aplusp)(ARGS_fadda); DIFFERENTIAL_EQUATIONS_IMPEXP void C2F(fadda)(ARGS_fadda); DIFFERENTIAL_EQUATIONS_IMPEXP void C2F(setfadda)(char *name, int *rep); FTAB FTab_fadda[] = { {"aplusp", (voidf) C2F(aplusp)}, {(char *) 0, (voidf) 0} }; /**************** fj2 ***************/

// // intzheev -- // Interface to LAPACK's ZHEEV // Computes the eigenvalues and, if required, the eigenvectors of a complex symmetric matrix. // Possible uses : // * With 1 LHS : // eigenvalues=spec(A) // where // A : symmetric, square matrix of size NxN // eigenvalues : matrix of size Nx1, type real // * With 2 LHS : // [eigenvectors,eigenvalues]=spec(A) // where // A : square matrix of size NxN // eigenvalues : matrix of size NxN with eigenvalues as diagonal terms, type real // eigenvectors : matrix of size NxN, type complex // int sci_zheev(char *fname, unsigned long fname_len) { int totalsize; int iRows = 0; int iCols = 0; int ONE = 1; int iWorkSize; int iRWorkSize; int INFO; char JOBZ; char UPLO; double *pdblDataReal = NULL; double *pdblDataImg = NULL; double *pdblFinalEigenvalues = NULL; //SCILAB return Var double *pdblEigenValues = NULL; //return by LAPACK double *pdblRWork = NULL; // Used by LAPACK double *pdblFinalEigenvectorsReal; // returned by Scilab double *pdblFinalEigenvectorsImg; // returned by Scilab doublecomplex *pdblData = NULL; doublecomplex *pdblWork = NULL; // Used by LAPACK CheckRhs(1, 1); CheckLhs(1, 2); GetRhsVarMatrixComplex(1, &iRows, &iCols, &pdblDataReal, &pdblDataImg); totalsize = iRows * iCols; pdblData = oGetDoubleComplexFromPointer(pdblDataReal, pdblDataImg, totalsize); if (iRows != iCols) { Err = 1; SciError(20); vFreeDoubleComplexFromPointer(pdblData); return 0; } if (iCols == 0) { if (Lhs == 1) { LhsVar(1) = 1; vFreeDoubleComplexFromPointer(pdblData); return 0; } else if (Lhs == 2) { int lD; CreateVar(2, MATRIX_OF_DOUBLE_DATATYPE, &iCols, &iCols, &lD); LhsVar(1) = 1; LhsVar(2) = 2; vFreeDoubleComplexFromPointer(pdblData); return 0; } } if (C2F(vfiniteComplex) (&totalsize, pdblData) == 0) { SciError(264); vFreeDoubleComplexFromPointer(pdblData); return 0; } if (Lhs == 1) { iAllocMatrixOfDouble(2, iCols, ONE, &pdblFinalEigenvalues); } else { iAllocMatrixOfDouble(2, iCols, iCols, &pdblFinalEigenvalues); iAllocComplexMatrixOfDouble(3, iCols, iCols, &pdblFinalEigenvectorsReal, &pdblFinalEigenvectorsImg); } pdblEigenValues = (double *)MALLOC(sizeof(double) * iCols); iWorkSize = Max(1, 2 * iCols - 1); pdblWork = (doublecomplex *) MALLOC(sizeof(doublecomplex) * iWorkSize); iRWorkSize = Max(1, 3 * iCols - 2); pdblRWork = (double *)MALLOC(sizeof(double) * iRWorkSize); if (Lhs == 1) { JOBZ = 'N'; // Compute eigenvalues only; } else { JOBZ = 'V'; // Compute eigenvalues and eigenvectors. } UPLO = 'U'; C2F(zheev) (&JOBZ, &UPLO, &iCols, pdblData, &iCols, pdblEigenValues, pdblWork, &iWorkSize, pdblRWork, &INFO); // SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, // $ INFO ) FREE(pdblWork); FREE(pdblRWork); if (INFO != 0) { SciError(24); } if (Lhs == 1) { int INCX = 1; int INCY = 1; C2F(dcopy) (&iCols, pdblEigenValues, &INCX, pdblFinalEigenvalues, &INCY); LhsVar(1) = 2; } else { assembleEigenvaluesFromDoublePointer(iRows, pdblEigenValues, pdblFinalEigenvalues); vGetPointerFromDoubleComplex(pdblData, totalsize, pdblFinalEigenvectorsReal, pdblFinalEigenvectorsImg); LhsVar(1) = 3; // Eigenvectors are stored in variable #3 LhsVar(2) = 2; // Eigenvalues are stored in variable #2 } FREE(pdblEigenValues); vFreeDoubleComplexFromPointer(pdblData); return 0; }