Example #1
0
 */

#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));
    }
Example #2
0
/*--------------------------------------------------------------------------*/
int sci_ceil(char *fname, unsigned long fname_len)
{
    static int id[6];
    C2F(intceil)(id);
    return 0;
}
Example #3
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;
    }
}
Example #4
0
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);
    }
  }
Example #5
0
/*--------------------------------------------------------------------------*/
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;
}
Example #6
0
/*--------------------------------------------------------------------------*/
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;
}
Example #7
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;
}
Example #8
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;
}
Example #9
0
/*--------------------------------------------------------------------------*/
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;
}
Example #10
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;
}
Example #11
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;
}
Example #12
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;
}
Example #13
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;
}
Example #14
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;
} 
Example #15
0
/*--------------------------------------------------------------------------*/
int sci_fsolve(char *fname,unsigned long fname_len)
{
	C2F(scisolv)(fname,fname_len);
	return 0;
}
Example #16
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;
}
Example #17
0
    {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;
}
/*--------------------------------------------------------------------------*/
Example #18
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;
}
Example #19
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 ***************/
Example #20
0
//
// 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;
}