hmops.h File Reference

This graph shows which files directly or indirectly include this file:

Go to the source code of this file.

Functions
int C2F()	ishm (void)
int C2F()	intehm (void)
int C2F()	intihm (void)

---

Function Documentation

int C2F() intehm

(

void

)

Definition at line 638 of file hmops.c.

References create_index_vector(), CreateVar, Fin, get_hmat(), H, i, j, l, lc, LhsVar, lr, m, n, NOT_REAL_or_CMPLX_or_BOOL_or_INT, OLD_HYPERMAT, P, PutLhsVar, ReshapeHMat, and Rhs.

{
  /* 
   *  Extraction routine for an hypermatrix of type REAL_OR_COMPLEX, BOOLEAN
   *  and INTEGER (the 6 types of scilab ints) 
   *
   *    He = ehm ( v_1, v_2, ..., v_nb_iv, H ) 
   *
   */
  HyperMat H, He;
  int dec, i, k, l, m, n, mn, ntot, ind_max;
  int *j, ier, one=1, zero=0, ltot, nb_index_vectors, final_dimsize, lr, lc;
  int *P, *Pe;
  short int *siP, *siPe;
  char  *cP, *cPe;

/*   CheckLhs(minlhs,maxlhs); */

  if ( Rhs < 2 ) 
    {
      Scierror(999," an hypermat extraction must have at least 2 args ");
      return(0);
    };

  if ( ! get_hmat(Rhs, &H) )
    {
      Scierror(999," argument is not an hypermatrix ");
      return 0;
    }
  else if ( H.type == NOT_REAL_or_CMPLX_or_BOOL_or_INT  || H.type == OLD_HYPERMAT )
    {
      /*  do the extraction with the macro %hm_e  */
      Fin = -Fin;
      return 0;
    }

  nb_index_vectors = Rhs-1;
  if ( H.dimsize <  nb_index_vectors )
    {
      Scierror(999," incompatible hypermat extraction ");
      return 0;
    }
  else if ( H.dimsize > nb_index_vectors )  /* reshape H */
    {
      ReshapeHMat(Rhs+1, &H, nb_index_vectors );
      dec = Rhs+1;
    }
  else
    dec = Rhs;

  if ( H.size == 0 )   /* the hypermat is empty => return an empty matrix ? */
    {
      CreateVar(dec+1, "d", &zero, &zero, &l);
      LhsVar(1) = dec+1;
      PutLhsVar();
      return 0;
    }
 

  ntot = 1;   /* will be the nb of elts of the extracted hmat or mat */
  for ( i = 1 ; i <= nb_index_vectors ; i++ )
    {  
      ier = create_index_vector(i, dec+i, &mn, H.dims[i-1], &ind_max);
      if ( ier == 0  ||  ind_max > H.dims[i-1] )
        {
          Scierror(999,"bad (%d th) index in hypermat extraction ",i); return 0;
        }
      if ( mn == 0 )   /* the vector index is [] => we return an empty matrix */
        {
          CreateVar(dec+i+1, "d", &zero, &zero, &l);
          LhsVar(1) = dec+i+1;
          PutLhsVar();
          return 0;
        }
      ntot *= mn; 
    }

  /*  For the Matlab compatibility : an hypermatrix of profil n1 x ... x nj x ... x nk 
   *  with  nj > 1 and nj+1 = ... = nk = 1 becomes an hypermatrix of profil n1 x ... x nj 
   *  Moreover, in scilab, if nj <= 2, we get in fact a matrix.
   */
  final_dimsize = nb_index_vectors;
  while (final_dimsize > 1 && get_length(dec + final_dimsize) == 1)
    final_dimsize--;
  if ( final_dimsize > 2 )   /* we create an hypermatrix for the extraction result */
    {
      He.dimsize = final_dimsize;
      He.size = ntot;
      He.it = H.it;
      He.type = H.type;
      CreateHMat(dec+Rhs, &He);
      for ( k = 0 ; k < final_dimsize ; k++ )
        He.dims[k] = get_length(dec+k+1);
    }
  else                /* we create a matrix  for the extraction result */
    {
      m = get_length(dec+1); 
      if (final_dimsize > 1)
        n = get_length(dec+2);
      else
        n = 1;
      switch (H.type)
        {
        case (SCI_REAL_OR_CMPLX):
          CreateCVar(dec+Rhs, "d", &(H.it), &m, &n, &lr, &lc); 
          He.R = stk(lr); 
          if ( H.it == 1 ) He.I = stk(lc);
          break;
        case (SCI_BOOLEAN):
          CreateVar(dec+Rhs, "b", &m, &n, &lr); 
          He.P = (void *) istk(lr);
          break;
        case (SCI_INTEGER):
          lr = H.it;
          CreateVar(dec+Rhs, "I", &m, &n, &lr);
          He.P = (void *) istk(lr);
          break;
        }
    }

  /* indices computing */
  ltot = 4; CreateVar(dec+Rhs+1, "I", &ntot, &one, &ltot); j = istk(ltot);
  compute_indices(dec, nb_index_vectors, H.dims, j);

  /*  fill the resulting hypermatrix or matrix  */
  switch ( H.type )
    {
    case (SCI_REAL_OR_CMPLX) :
      for ( k = 0 ; k < ntot ; k++ )
        He.R[k] = H.R[j[k]];
      if (H.it == 1)
        for ( k = 0 ; k < ntot ; k++ )
          He.I[k] = H.I[j[k]];
      break;
      
    case (SCI_BOOLEAN) :     /* (sci_boolean stored with 4 bytes) */
      Pe = (int *) He.P ; P = (int *) H.P;
      for ( k = 0 ; k < ntot ; k++ )
        Pe[k] = P[j[k]];
      break;

    case (SCI_INTEGER) :
      if ( H.it == SCI_INT32  ||  H.it == SCI_UINT32 )
        {
          Pe = (int *) He.P; P = (int *) H.P;
          for ( k = 0 ; k < ntot ; k++ )
            Pe[k] = P[j[k]];
        }
      else if ( H.it == SCI_INT16  ||  H.it == SCI_UINT16 )
        {
          siPe = (short int *) He.P; siP = (short int *) H.P;
          for ( k = 0 ; k < ntot ; k++ )
            siPe[k] = siP[j[k]];
        }
      else    /* SCI_INT8 and SCI_UINT8 : 1 Byte int */
        {
          cPe = (char *) He.P; cP = (char *) H.P;
          for ( k = 0 ; k < ntot ; k++ )
            cPe[k] = cP[j[k]];
        }
      break;
    }
  
  LhsVar(1) = dec+Rhs;
  PutLhsVar();
  return 0;
}

Here is the call graph for this function:

int C2F() intihm

(

void

)

Definition at line 807 of file hmops.c.

References A, B, compute_indices(), create_index_vector(), CreateVar, Fin, get_hmat(), get_mat_as_hmat(), i, ilp, istk, j, NOT_REAL_or_CMPLX_or_BOOL_or_INT, OLD_HYPERMAT, ReshapeHMat, Rhs, SCI_INT16, SCI_INT32, SCI_INTEGER, SCI_REAL_OR_CMPLX, SCI_UINT16, SCI_UINT32, and topk.

{
  /* 
      une routine d'insertion pour hypermatrice : cas le plus
      simple :   A( vi1, ..., vik ) = B

        ihm ( vi1, vi2, ..., vik, B, A ) 

      avec des vecteurs d'indices classiques vi1, vi2, ....
      et B une hypermatrice ou bien une matrice
   */

  HyperMat A, B;
  int i, k,/* l, li, m, n,*/ ntot, mn,/* err_neg,*/ iconf, ind_max;
  int nb_index_vectors, B_is_scalar;
  int *j,/* nd,*/ one=1, ltot, il, dec/*, Top_save*/;
  int *PA, *PB;
  short int *siPA, *siPB;
  char *cPA, *cPB;
  int ilp, topk;

/*   CheckLhs(minlhs,maxlhs); */

  if ( Rhs < 3 ) 
    {
      Scierror(999," an hypermat insertion must have at least 3 args ");
      return 0;
    };
  nb_index_vectors = Rhs - 2;

  if ( ! get_hmat(Rhs, &A) )
    {
      Scierror(999," argument is not an hypermatrix ");
      return 0;
    }
  else if ( A.type == NOT_REAL_or_CMPLX_or_BOOL_or_INT  || A.type == OLD_HYPERMAT )
    {
      /* do the job by the %x_i_hm macro family */
      Fin = -Fin;
      return 0;
    }

  if ( ! get_hmat(Rhs-1, &B) )   /* B is not an hypermat => try if it is a matrix */
    if ( ! get_mat_as_hmat(Rhs-1, &B) )  /* it is not a matrix of type 1, 4 or 8 */
      {
        /* it stays some authorized possibilities like A(....) = B with B a polynomial
         * matrix and A a real hypermatrix => try the %x_i_hm macro family 
         */
        Fin = -Fin;
        return 0;
      }


  if ( A.type !=  B.type || A.it != B.it || B.size == 0  || A.dimsize <  nb_index_vectors ) 
    {
      /*  do the job by the %x_i_hm macro family */
      Fin = -Fin;
      return 0;
    }

  if ( B.size == 1 )
    B_is_scalar = 1;
  else
    B_is_scalar = 0;


  if ( A.dimsize > nb_index_vectors )
    {
      ReshapeHMat(Rhs+1, &A, nb_index_vectors);
      dec = Rhs+1;
    }
  else
    dec = Rhs;


  /* get the index vectors */
  ntot = 1;
  iconf = 0;
  for ( i = 1 ; i <= nb_index_vectors ; i++ )
    {  
      if (! create_index_vector(i, dec+i, &mn, A.dims[i-1], &ind_max)) return 0;
      if ( mn == 0 )   /* the i th index vector is [] */
        {
          if ( B_is_scalar )
            /* nothing append (strange but reproduces the Matlab behavior) */
            goto the_end;
          else   /* B have at least 2 elts */
            {
              Scierror(999," bad hypermat insertion "); return 0;
            }
        }
      else if ( ind_max > A.dims[i-1] )
        {
          /* we have to enlarge the hypermat : do the job by the %x_i_hm macro family */
          Fin = -Fin;
          return 0;
        }
      else if ( !B_is_scalar  &&  mn != 1 )  /* do the conformity test */
        {
          while ( iconf < B.dimsize  &&  B.dims[iconf] == 1 )
            iconf++;
          if ( iconf >= B.dimsize  ||  B.dims[iconf] != mn )
            {
              Scierror(999," bad hypermat insertion ");
              return 0;
            }
          iconf++;
        }
      ntot *= mn; 
    }
  /* to finish the conformity test */
  if ( !B_is_scalar &&  ntot != B.size )
    {
      Scierror(999," bad hypermat insertion ");
      return 0;
    }

  /* indices computing */
  ltot = 4; CreateVar(dec+Rhs-1, "I", &ntot, &one, &ltot); j = istk(ltot);
  compute_indices(dec, nb_index_vectors, A.dims, j);

  
  /*   modify in place the hypermatrix A  */
  switch ( A.type )
    {
    case (SCI_REAL_OR_CMPLX) :
      if ( B_is_scalar )
        {
          for ( k = 0 ; k < ntot ; k++ ) A.R[j[k]] = B.R[0];
          if (A.it == 1)
            for ( k = 0 ; k < ntot ; k++ ) A.I[j[k]] = B.I[0];
        }
      else
        {
          for ( k = 0 ; k < ntot ; k++ ) A.R[j[k]] = B.R[k];
          if (A.it == 1)
            for ( k = 0 ; k < ntot ; k++ ) A.I[j[k]] = B.I[k];
        }
      break;
      
    case (SCI_BOOLEAN) :
      PA = (int *) A.P ; PB = (int *) B.P;
      if ( B_is_scalar )
        for ( k = 0 ; k < ntot ; k++ ) PA[j[k]] = PB[0];
      else
        for ( k = 0 ; k < ntot ; k++ ) PA[j[k]] = PB[k];
      break;

    case (SCI_INTEGER) :
      if ( A.it == SCI_INT32  ||  A.it == SCI_UINT32 )
        {
          PA = (int *) A.P ; PB = (int *) B.P;
          if ( B_is_scalar )
            for ( k = 0 ; k < ntot ; k++ ) PA[j[k]] = PB[0];
          else
            for ( k = 0 ; k < ntot ; k++ ) PA[j[k]] = PB[k];
        }
      else if ( A.it == SCI_INT16  ||  A.it == SCI_UINT16 )
        {
          siPA = (short int *) A.P; siPB = (short int *) B.P;
          if ( B_is_scalar )
            for ( k = 0 ; k < ntot ; k++ ) siPA[j[k]] = siPB[0];
          else
            for ( k = 0 ; k < ntot ; k++ ) siPA[j[k]] = siPB[k];
        }
      else   /* 1 Byte int */
        {
          cPA = (char *) A.P; cPB = (char *) B.P;
          if ( B_is_scalar )
            for ( k = 0 ; k < ntot ; k++ ) cPA[j[k]] = cPB[0];
          else
            for ( k = 0 ; k < ntot ; k++ ) cPA[j[k]] = cPB[k];
        }
      break;
    }

/*
 *  ici j'essaie de faire le boulot de putlhsvar
 *  le code se base sur  setref (SCI/system/createref.f)
 *  on met une variable speciale "en Top" (le nouveau
 *  Top = Top-Rhs+1) qui indique en fait que l'on a
 *  modifié "en place" la variable topk.
 *  Les instructions  LhsVar(1) = 0; et Nbvars = 0;
 *  permettent a priori de sortir "convenablement"
 *  de putlhsvar.
 */
 the_end:
  il = iadr(*Lstk(Top));
  topk = *istk(il + 2);
  Top = Top - Rhs + 1;
  ilp = iadr(*Lstk(Top));
  *istk(ilp) = -1;
  *istk(ilp+1) = -1;
  *istk(ilp+2) = topk;
  if ( topk > 0 )
    *istk(ilp+3) = *Lstk(topk+1) - *Lstk(topk);
  else
    *istk(ilp+3) = 0;
  *Lstk(Top+1) = sadr(ilp+4);

  LhsVar(1) = 0;
  Nbvars = 0;

  return 0;
}

Here is the call graph for this function:

int C2F() ishm

(

void

)

Definition at line 182 of file hmops.c.

References iadr, il1, istk, Lstk, sadr, SCI_MLIST, SCI_STRING, and Top.

{
  /* teste si l'argument en Top est une hypermatrice */
  int il, il1, il2;
  il = iadr(*Lstk( Top )); 
  if ( *istk(il) < 0 )
    il = iadr(*istk(il+1));
          
  if ( *istk(il) != SCI_MLIST )
    return 0;
  else if ( *istk(il+1) != 3 )  /* a hm mlist must have 3 fields */
    return 0;

  /*  get the pointer of the first and second fields */
  il1 = sadr(il+6);
  il2 = il1 + *istk(il+3) - 1;
  il1 = iadr(il1); il2 = iadr(il2);

  /*  test if the first field is a matrix string with 3 components
   *  and that the first is "hm" (ie 17 22  in scilab char code)
   */
  if ( (*istk(il1) != SCI_STRING)  |  ((*istk(il1+1))*(*istk(il1+2)) != 3)  )
    return 0;
  else if ( *istk(il1+5)-1 != 2 )  /* 1 str must have 2 chars */
    return 0;
  else if ( *istk(il1+8) != 17  || *istk(il1+9) != 22 )
    return 0;

  return 1;
}      

---