Ejemplo n.º 1
0
static void MkEndo(const MatRep_t *rep, const CfInfo *cf,
    Matrix_t **endo, int maxendo)

{
    Matrix_t *pw, *nsp;
    WgData_t *wg;

    MTX_VERIFY(maxendo >= cf->spl);

    /* Make the peak word kernel
       ------------------------- */
    wg = WgAlloc(rep);
    pw = WgMakeWord(wg,cf->idword);
    WgFree(wg);
    nsp = MatNullSpace__(MatInsert(pw,cf->idpol));
    MTX_ASSERT(nsp->Nor == cf->spl);
    MatFree(pw);

    /* Calculate a basis of the the endomorphism ring
       ---------------------------------------------- */
    const int i = MakeEndomorphisms(rep,nsp,endo);
    (void)i;
    MTX_ASSERT(i == 0);

    MatFree(nsp);
}
Ejemplo n.º 2
0
static void MakeQ(int n, int spl, const Matrix_t **endo)

{		  
    int i;
    int dim = endo[0]->Nor;
    Matrix_t *q = MatAlloc(endo[0]->Field,spl,dim*dim);
    char fn[200];
    for (i = 0; i < spl; ++i)
    {
	int j;
	Matrix_t *y = MatInverse(Trans[n]), *x;
	MatMul(y,endo[i]);
	x = MatTransposed(y);
	MatFree(y);
	for (j = 0; j < dim; ++j)
	    MatCopyRegion(q,i,j * dim,x,j,0,1,-1);
	MatFree(x);
    }
    sprintf(fn,"%s.q.%d",TkiName,n+1);
    MESSAGE(2,("Writing %s\n",fn));

#if 0
    if (InfoM.Cf[TKInfo.CfIndex[0][n]].peakword < 0)
	MatMulScalar(q,FF_ZERO);
#endif

    MatSave(q,fn);
    MatFree(q);
}
Ejemplo n.º 3
0
static void gkond(const Lat_Info *li, int i, Matrix_t *b, Matrix_t *k, 
    Matrix_t *w, const char *name)

{
    char fn[LAT_MAXBASENAME+10];
    Matrix_t *x1, *x2;

    x1 = MatDup(k);
    MatMul(x1,w);
    x2 = QProjection(b,x1);
    sprintf(fn,"%s%s.%s",li->BaseName,Lat_CfName(li,i),name);
    MatSave(x2,fn);
    MatFree(x1);
    MatFree(x2);
}
Ejemplo n.º 4
0
Matrix_t *MatInverse(const Matrix_t *mat)
{
   PTR tmp = NULL;      // workspace
   Matrix_t *dest;

   if (!MatIsValid(mat)) {
      return NULL;
   }
   if (mat->Nor != mat->Noc) {
      MTX_ERROR1("%E",MTX_ERR_NOTSQUARE);
      return NULL;
   }
   dest = MatId(mat->Field,mat->Nor);
   if (dest == NULL) {
      return NULL;
   }

   // Copy matrix into workspace
   tmp = FfAlloc(mat->Nor);
   if (tmp == NULL) {
      return NULL;
   }
   memcpy(tmp,mat->Data,FfCurrentRowSize * mat->Nor);

   // Inversion
   if (zmatinv(tmp,dest->Data) != 0) {
      MatFree(dest);
      return NULL;
   }
   return dest;
}
Ejemplo n.º 5
0
/*******************************+++*******************************/
void DbOutputMatStatus(void)
/*****************************************************************/
/*   Purpose:  Output status of output matrices.                 */
/*                                                               */
/*   Version:  1995 May 12                                       */
/*****************************************************************/
{
     Matrix    OutMatStatus;
     size_t    i, ii;

     MatAllocate(0, 2, RECT, STRING, NULL, YES, &OutMatStatus);
     MatPutColName(&OutMatStatus, 0, "Matrix");
     MatPutColName(&OutMatStatus, 1, "Contains");
     MatPutText(&OutMatStatus, "Output-matrix status:\n");

     for (ii = 0, i = 0; i < MatNumRows(&DbStatus); i++)
     {
          if (DbStatus.RowName[i] == NULL)
               /* Not an output matrix. */
               continue;

          MatReAlloc(ii + 1, 2, &OutMatStatus);
          MatPutStrElem(&OutMatStatus, ii, 0,
                    MatStrElem(&DbStatus, i, DB_STATUS_OBJ_COL));
          MatPutStrElem(&OutMatStatus, ii, 1,
                    MatRowName(&DbStatus, i));
          ii++;
     }

     /* Do not write case labels. */
     MatWriteBlock(&OutMatStatus, NO, stdout);
     Output("\n");
     MatFree(&OutMatStatus);
}
Ejemplo n.º 6
0
Matrix_t *MatNullSpace__(Matrix_t *mat)
{
   Matrix_t *nsp;
   nsp = MatNullSpace_(mat,0);
   MatFree(mat);
   return nsp;
}
Ejemplo n.º 7
0
int MsFree(MatrixSet_t *set)
{
    int i;
    if (!MsIsValid(set))
	return -1;
    for (i = 0; i < set->Len; ++i)
	MatFree(set->List[i].Matrix);
    SysFree(set->List);
    memset(set,0,sizeof(*set));
    return 0;
}
Ejemplo n.º 8
0
static void Standardize(int cf)

{
    int k, m;
    Matrix_t *sb;
    IntMatrix_t *script = NULL;
    Matrix_t *std[MAXGEN];

    /* Make the spin-up script for the standard basis and
       transform the generators.
       -------------------------------------------------- */
    MESSAGE(0,("  Transforming to standard basis\n"));
    sb = SpinUp(CfList[cf].PWNullSpace,CfList[cf].Gen,
	SF_FIRST|SF_CYCLIC|SF_STD,&script,NULL);
    ChangeBasisOLD(sb,CfList[cf].Gen->NGen,
	(const Matrix_t **)CfList[cf].Gen->Gen,std);
    MatFree(sb);

    /* Write the transformed generators and the spin-up script.
       -------------------------------------------------------- */
    for (m = 0; m < CfList[cf].Mult; ++m)
    {
	char fn[200];
	Lat_Info *li = &ModList[CfList[cf].CfMap[m][0]].Info;
	int i = CfList[cf].CfMap[m][1];
	sprintf(fn,"%s%s.op",li->BaseName,Lat_CfName(li,i));
	MESSAGE(2,("Write operations to %s\n",fn));
	if (ImatSave(script,fn) != 0)
	    MTX_ERROR("Cannot write .op file");
	for (k = 0; k < li->NGen; ++k)
	{
    	    sprintf(fn,"%s%s.std.%d",li->BaseName,Lat_CfName(li,i),k+1);
    	    MESSAGE(2,(" %s",fn));
	    MatSave(std[k],fn);
	}
    }

    for (k = 0; k < ModList[0].Info.NGen; ++k)
	MatFree(std[k]);
    ImatFree(script);
}
Ejemplo n.º 9
0
Matrix_t *MatNullSpace_(Matrix_t *mat, int flags)
{
   long dim;
   Matrix_t *nsp;

   // check arguments
   if (!MatIsValid(mat)) {
      return NULL;
   }

   // allocate workspace
   nsp = MatAlloc(mat->Field,mat->Nor,mat->Nor);
   if (nsp == NULL) {
      return NULL;
   }
   nsp->PivotTable = NREALLOC(nsp->PivotTable,int,mat->Nor);
   if (nsp->PivotTable == NULL)
   {
       MatFree(nsp);
       return NULL;
   }

   // calculate the null-space
   FfSetNoc(mat->Noc);
   dim = znullsp(mat->Data,mat->Nor,nsp->PivotTable,nsp->Data,flags);
   if (dim == -1)
   {
      MatFree(nsp);
      return NULL;
   }
   if (flags) {
      SysFree(nsp->PivotTable);
      nsp->PivotTable = NULL;
   }

   // resize the result buffer to its actual size
   nsp->Nor = dim;
   nsp->Data = (PTR) SysRealloc(nsp->Data,nsp->RowSize * dim);

   return nsp;
}
Ejemplo n.º 10
0
Matrix_t *QAction(const Matrix_t *subspace, const Matrix_t *gen)
{
   int k;
   int dim, sdim, qdim;
   int *piv, *non_piv;

   /* Check arguments.
      ---------------- */
   if (!MatIsValid(subspace) || !MatIsValid(gen)) {
      return NULL;
   }
   if (subspace->Noc != gen->Nor) {
      MTX_ERROR1("subspace and gen: %E",MTX_ERR_INCOMPAT);
      return NULL;
   }
   if (gen->Nor != gen->Noc) {
      MTX_ERROR1("gen: %E",MTX_ERR_NOTSQUARE);
      return NULL;
   }

   /* Initialize
      ---------- */
   dim = subspace->Noc;
   sdim = subspace->Nor;
   qdim = dim - sdim;
   Matrix_t *action = MatAlloc(subspace->Field,qdim,qdim);
   if (action == NULL) {
      return NULL;
   }

   /* Calculate the action on the quotient
      ------------------------------------ */
   FfSetNoc(dim);
   PTR tmp = FfAlloc(1);
   if (tmp == NULL) {
      MatFree(action);
      return NULL;
   }
   piv = subspace->PivotTable;
   non_piv = piv + subspace->Nor;
   for (k = 0; k < qdim; ++k) {
      int l;
      PTR qx = MatGetPtr(action,k);
      FfCopyRow(tmp,MatGetPtr(gen,non_piv[k]));
      FfCleanRow(tmp,subspace->Data,sdim,piv);
      for (l = 0; l < qdim; ++l) {
         FfInsert(qx,l,FfExtract(tmp,non_piv[l]));
      }
   }
   SysFree(tmp);

   return action;
}
Ejemplo n.º 11
0
FPoly_t *Factorization(const Poly_t *pol)
{
    factor_t *list, *l;
    FPoly_t *factors;    

    /* Allocate result
       --------------- */
    if ((factors = FpAlloc()) == NULL)
    {
	MTX_ERROR("Cannot allocate result");
	return NULL;
    }

    /* Step 1: Squarefree factorization
       -------------------------------- */
    if ((list = factorsquarefree(pol)) == NULL)
    {
	MTX_ERROR("Squarefree factorization failed");
	return NULL;
    }

    /* Step 2: Decompose the squarefree factors using Berlekamp's algorithm
       -------------------------------------------------------------------- */
    for (l = list; l->p != NULL; ++l)
    {
	Matrix_t *kernel;
	Poly_t **irr, **i;

	kernel = makekernel(l->p);
	if ((irr = berlekamp(l->p,kernel)) == NULL)
	{
	    MTX_ERROR("Berlekamp factorization failed");
	    return NULL;
	}
	MatFree(kernel);
	for (i = irr; *i != NULL; ++i)
	{
	    FpMulP(factors,*i,l->n);
	    PolFree(*i);
	}

	/* Clean up
	   -------- */
	SysFree(irr);
	PolFree(l->p);
    }

    /* Clean up
       -------- */
    SysFree(list);
    return factors;
}
Ejemplo n.º 12
0
int StablePower(const Matrix_t *mat, int *pwr, Matrix_t **ker)
{
   int rc;
   Matrix_t *tmp;

   tmp = MatDup(mat);
   if (tmp == NULL) {
      MTX_ERROR1("mat: %E",MTX_ERR_BADARG);
      return -1;
   }
   rc = StablePower_(tmp,pwr,ker);
   MatFree(tmp);
   return rc;
}
Ejemplo n.º 13
0
int MrFree(MatRep_t *rep)
{
   int i;
   if (!MrIsValid(rep)) {
      MTX_ERROR1("%E",MTX_ERR_BADARG);
      return -1;
   }
   for (i = 0; i < rep->NGen; ++i) {
      MatFree(rep->Gen[i]);
   }
   memset(rep->Gen,0,sizeof(Matrix_t *) * rep->NGen);
   SysFree(rep->Gen);
   memset(rep,0,sizeof(MatRep_t));
   SysFree(rep);
   return 0;
}
Ejemplo n.º 14
0
MatRep_t *MrAlloc(int ngen, Matrix_t **gen, int flags)
{
   MatRep_t *rep;
   int i;

   if (!GensAreValid(ngen,gen)) {
      MTX_ERROR1("%E",MTX_ERR_BADARG);
      return NULL;
   }

   // Allocate a new MatRep_t structure
   rep = ALLOC(MatRep_t);
   if (rep == NULL) {
      MTX_ERROR("Cannot allocate MatRep_t structure");
      return NULL;
   }
   memset(rep,0,sizeof(MatRep_t));
   rep->Gen = NALLOC(Matrix_t *,ngen);
   if (rep->Gen == NULL) {
      MTX_ERROR("Cannot allocate generator list");
      SysFree(rep);
      return NULL;
   }

   // Copy generators
   rep->NGen = ngen;
   for (i = 0; i < ngen; ++i) {
      if (flags & MR_COPY_GENERATORS) {
         rep->Gen[i] = MatDup(gen[i]);
         if (rep->Gen[i] == NULL) {
            MTX_ERROR("Cannot copy generator");
            while (--i >= 0) {
               MatFree(rep->Gen[i]);
            }
            SysFree(rep->Gen);
            SysFree(rep);
            return NULL;
         }
      } else {
         rep->Gen[i] = gen[i];
      }
   }

   rep->Magic = MR_MAGIC;
   return rep;
}
Ejemplo n.º 15
0
test_F GreasedMapRow()
{
   while (NextField() > 0) {
      int gr_level;
      int max_gr_level;
      int fpow;
      Matrix_t *m = RndMat(FfOrder,20,20);
      for (fpow = FfOrder, max_gr_level = 1;
           max_gr_level <= 16 && fpow < 66000;
           ++max_gr_level, fpow *= FfOrder) {
      }
      --max_gr_level;
      for (gr_level = 0; gr_level <= max_gr_level; ++gr_level) {
         TestGrMapRow1(m,gr_level);
      }
      MatFree(m);
   }
}
Ejemplo n.º 16
0
Matrix_t *MatNullSpace(const Matrix_t *mat)
{
   Matrix_t *tmp, *nsp;

   // Check arguments
#ifdef DEBUG
   if (!MatIsValid(mat)) {
      return NULL;
   }
#endif

   // Non-destructive null-space
   if ((tmp = MatDup(mat)) == NULL) {
      MTX_ERROR("Cannot duplicate matrix");
      return NULL;
   }
   nsp = MatNullSpace_(tmp,0);
   MatFree(tmp);
   return nsp;
}
Ejemplo n.º 17
0
static void TestGrMapRow1(Matrix_t *m, int gr_level)
{
   Matrix_t *input = RndMat(FfOrder,m->Nor,m->Nor);
   GreasedMatrix_t *gm = GrMatAlloc(m,gr_level);
   PTR res_std = FfAlloc(1);
   PTR res_grease = FfAlloc(1);
   int i;

   for (i = 0; i < m->Nor; ++i) {
      PTR vec = MatGetPtr(input,i);
      FfSetNoc(m->Noc);
      FfMapRow(vec,m->Data,m->Nor,res_std);
      GrMapRow(vec,gm,res_grease);
      ASSERT_EQ_INT(FfCmpRows(res_grease,res_std), 0);
   }
   SysFree(res_std);
   SysFree(res_grease);
   MatFree(input);
   GrMatFree(gm);
}
Ejemplo n.º 18
0
static void kond(int mod, int cf)

{
    const Lat_Info *li = &ModList[mod].Info;
    char fn[LAT_MAXBASENAME+10];
    Matrix_t *peakword, *kern, *m, *k, *pw;
    int j, pwr;
		
    /* Make the peak word, find its stable power, 
       and calculate both kernel and image.
       ------------------------------------------ */
    peakword = WgMakeWord(ModList[mod].Wg,li->Cf[cf].peakword);
    MatInsert_(peakword,li->Cf[cf].peakpol);
    pw = MatDup(peakword);
    StablePower_(peakword,&pwr,&kern);
    MESSAGE(0,("pwr=%d, nul=%d, ",pwr,kern->Nor));
    if (kern->Nor != li->Cf[cf].mult * li->Cf[cf].spl)
	MTX_ERROR("Something is wrong here!");
    MatEchelonize(peakword);

    /* Write out the image
       ------------------- */
     if (!opt_n)
     {
	sprintf(fn,"%s%s.im",li->BaseName,Lat_CfName(li,cf));
	MatSave(peakword,fn);
     }

    /* Write out the `uncondense matrix'
       --------------------------------- */
    m = QProjection(peakword,kern);
    k = MatInverse(m);
    MatFree(m);
    MatMul(k,kern);
    sprintf(fn,"%s%s.k",li->BaseName,Lat_CfName(li,cf));
    MatSave(k,fn);

    /* Condense all generators
       ----------------------- */
    MESSAGE(1,("("));
    for (j = 0; j < li->NGen; ++j)
    {
	sprintf(fn,"%dk",j+1);
	gkond(li,cf,peakword,k,ModList[mod].Rep->Gen[j],fn);
	MESSAGE(1,("%d",j+1));
    }
    MESSAGE(1,(")"));

    /* Condense the peak word
       ---------------------- */
    gkond(li,cf,peakword,k,pw,"np");

    /* Calculate the semisimplicity basis.
       -----------------------------------  */
    if (opt_b)
    {
	Matrix_t *seed, *partbas;
	int pos = CfPosition(li,cf);
	seed = MatNullSpace_(pw,0);
	partbas = SpinUp(seed,ModList[mod].Rep,SF_EACH|SF_COMBINE|SF_STD,NULL,NULL);
        MatFree(seed);
	MESSAGE(0,(", %d basis vectors",partbas->Nor));
	if (MatCopyRegion(ModList[mod].SsBasis,pos,0,partbas,0,0,-1,-1) != 0)
	{
	    MTX_ERROR1("Error making basis - '%s' is possibly not semisimple",
		li->BaseName);
	}
        MatFree(partbas);
    }
    MatFree(pw);

    MESSAGE(0,("\n"));

    MatFree(k);
    MatFree(kern);
    MatFree(peakword);

}
Ejemplo n.º 19
0
/*******************************+++*******************************/
int CalcCV(KrigingModel *KrigMod, real *YHatCV, real *SE)
/*****************************************************************/
/* Purpose:    Compute kriging cross-validation predictions and, */
/*             optionally, their standard errors.                */
/*                                                               */
/* Args:       KrigMod   Input: Kriging model without            */
/*                       decompositions.                         */
/*                       Output: Decompositions are garbage.     */
/*             YHatCV    Output: Cross-validation predictions.   */
/*             SE        Output: Standard errors (computed only  */
/*                       if SE != NULL).                         */
/*                                                               */
/* Returns:    OK or an error number.                            */
/*                                                               */
/* Comment:    Calling routine must allocate space for YHatCV    */
/*             and SE.                                           */
/*             Better matrix updating for doing this?            */
/*             KrigMod decompositions are changed.               */
/*             Standard errors include contribution from epsilon */
/*             in predicted observation.                         */
/* 1995.02.21: SigmaSq not recomputed.                           */
/* 1996.04.12: Temporary output showing progress.                */
/*                                                               */
/* Version:    1996.04.12                                        */
/*****************************************************************/
{
    int       ErrNum;
    Matrix    C, FTilde;
    Matrix    *Chol, *F, *Q, *R;
    real      c, s, t;
    real      *Col, *Beta, *f, *r, *RBeta, *ResTilde, *Y, *YTilde;
    size_t    i, ii, j, k, m, n;

    Y    = KrigY(KrigMod);
    F    = KrigF(KrigMod);
    Chol = KrigChol(KrigMod);
    Q    = KrigQ(KrigMod);
    R    = KrigR(KrigMod);

    /* Use workspace in KrigMod. */
    f        = KrigMod->fRow;
    r        = KrigMod->r;
    RBeta    = KrigMod->RBeta;
    Beta     = KrigMod->Beta;
    ResTilde = KrigMod->ResTilde;

    n = MatNumRows(F);
    k = MatNumCols(F);

    if (n == 0)
        return OK;
    else if (n == 1)
    {
        YHatCV[0] = NA_REAL;
        if (SE != NULL)
            SE[0] = NA_REAL;
        return OK;
    }

    MatAlloc(n, n, UP_TRIANG, &C);
    MatAlloc(n, k, RECT, &FTilde);
    YTilde = AllocReal(n, NULL);

    MatPutNumRows(Q, n - 1);

    /* Put correlation matrix in C. */
    KrigCorMat(0, NULL, KrigMod);
    MatCopy(Chol, &C);

    /* Overwrite correlation matrix with Cholesky decomposition. */
    if (TriCholesky(Chol, 0, Chol) != OK)
    {
        Error("Ill-conditioned Cholesky factor.\n");
        ErrNum = NUMERIC_ERR;
    }
    else
        ErrNum = OK;

    /* Compute FTilde and YTilde for all n rows. */
    if (ErrNum == OK)
        ErrNum = KrigSolve(Chol, F, Y, &FTilde, YTilde);

    /* Delete case i and predict Y[i]. */
    for (i = n - 1, ii = 0; ii < n && ErrNum == OK; ii++, i--)
    {
        OutputTemp("Cross validating variable: %s  Run: %d",
                   yName, i + 1);

        /* Permute adjacent columns of Chol until  */
        /* column i is moved to the last column.   */
        for (j = i; j < n - 1; j++)
        {
            TriPerm(j, j + 1, Chol, &c, &s);

            /* Apply the same rotation to YTilde and FTilde. */
            t           =  c * YTilde[j] + s * YTilde[j+1];
            YTilde[j+1] = -s * YTilde[j] + c * YTilde[j+1];
            YTilde[j]   = t;
            for (m = 0; m < k; m++)
            {
                Col      = MatCol(&FTilde, m);
                t        =  c * Col[j] + s * Col[j+1];
                Col[j+1] = -s * Col[j] + c * Col[j+1];
                Col[j]   = t;
            }
        }

        /* Correlations between case i and the other cases.  */
        /* Note that cases after i are now in reverse order. */
        for (j = 0; j < i; j++)
            r[j] = MatElem(&C, j, i);
        for (j = 0; j < n - 1 - i; j++)
            r[i+j] = MatElem(&C, i, n - 1 - j);

        /* Linear model terms for case i. */
        MatRow(F, i, f);

        /* Pretend we have only n - 1 cases. */
        MatPutNumRows(Chol, n - 1);
        MatPutNumCols(Chol, n - 1);
        MatPutNumRows(&FTilde, n - 1);

        /* Gram-Schmidt QR orthogonalization of FTilde. */
        if (QRLS(&FTilde, YTilde, Q, R, RBeta, ResTilde) != OK)
        {
            Error("Cannot perform QR decomposition.\n");
            ErrNum = NUMERIC_ERR;
        }

        else
        {
            /* Leave-one-out beta's can be obtained as follows. */
            /*
            if (TriBackSolve(R, RBeta, Beta) != OK)
                 Error("Cannot compute regression beta's.\n");
            else
            {
                 for (j = 0; j < k; j++)
                      Output(" %e", Beta[j]);
                 Output("\n");
            }
            */

            if (SE != NULL)
            {
                /* Standard error required.             */
                /* KrigMod->SigmaSq is not updated.     */
                /* RAve = 1.0 for epsilon contribution. */
                ErrNum = KrigYHatSE(KrigMod, 1.0, f, r,
                                    &YHatCV[i], &SE[i]);
            }
            else
                /* No standard error. */
                ErrNum = KrigYHatSE(KrigMod, 1.0, f, r,
                                    &YHatCV[i], NULL);
        }

        /* Restore sizes of Chol and FTilde. */
        MatPutNumRows(Chol, n);
        MatPutNumCols(Chol, n);
        MatPutNumRows(&FTilde, n);
    }

    OutputTemp("");

    if (ErrNum != OK)
        for (i = 0; i < n; i++)
            YHatCV[i] = SE[i] = NA_REAL;

    MatPutNumRows(Q, n);

    MatFree(&C);
    MatFree(&FTilde);
    AllocFree(YTilde);

    return ErrNum;
}
Ejemplo n.º 20
0
int main(int argc,char *argv[])
{
  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  //VARIABLE DEFINITION
  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  float cp,S,sigma,gamma,pp,Topt;
  float q,Ab,Aw,Agf,grad_T,fi,mm,nn,Pmax,EVPmax;
  float Ec,Es,deltat,t_integracion,t_modelacion;
  float Lini,Lfin,deltaL;
  int niter,niterL,nzc;
  Vector zc_vector;
  int zczc,ii;
  float Ac,L,zc;
  float aclouds,awhite,ablack,Ts,d;
  float t,xx,As;
  float k1,k2,k3,k4;
  int j;
  float Tc,Tlb,Tlw,Tanual,I,a,EVP,E;
  float P;
  float k1c,k2c,k3c,k4c;
  float k1w,k2w,k3w,k4w;
  float k1b,k2b,k3b,k4b;
  float Bw,Bb;
  int it;
  Vector time,temperature,white_temperature,
    black_temperature,white_area,black_area,clouds_area,evap,prec;
  Matrix resultados;
  FILE *fl;
  char fname[1000];

  float k1p1,k1p2,k1p3,k1p4,k1p5;

  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  //PARAMETERS
  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  cp = 3.e13;	//erg*cm-2*K-1
  S = 2.89e13;	//erg*cm-2*año-1
  sigma = 1789.;	//erg*cm-2*año-1*K-4
  gamma = 0.3;	//año-1
  pp = 1.;	//adimensional
  Topt = 295.5;	//K
  q = 20.;	//K
  Ab = 0.25;	//adimensinal
  Aw = 0.75;	//adimensinal
  Agf = 0.50;	//adimensinal
  grad_T = (-0.0065);	//K*m-1, Trenberth 95, p.10
  
  fi = 0.1;
  mm = 0.35;
  nn = 0.1;
  Pmax = pow((1./mm),(1/nn)); //=36251 [mm/año], cuando ac=1.0
  EVPmax = Pmax;
  //EVPmax = 1511.; //[mm/año] corresponde a Ts=26 grados centígrados
  //Pmax = EVPmax;	//[mm/año]
  //ac_crit = mm*Pmax^nn;

  //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
  //experimento otro: cambiando estos parámetros
  Ec=1.;	//emisividad de las nubes
  Es=1.;	//emisividad de la superficie
  //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

  deltat = 0.01; //[años] tamaño de paso temporal para dTsdt y dadt
  t_integracion = 1; //[año] cada cuanto se guardan valores de las variables
  t_modelacion = 10000;	//[años] período de modelación por cada L
  niter = t_integracion/deltat;	//# de iteraciones en los RK4

  /*
    Lini = 1.992;
    Lfin = 4.004;
    deltaL = 0.004;
  */
  Lini = 1.000;
  Lfin = 1.000;
  deltaL = 0.004;
  niterL = (Lfin-Lini)/deltaL;

  ////zc_vector = [1000.,2000.,3000.,4000.,5000.,6000.,7000.,8000.]
  zc_vector=VecAlloc(1);
  VecSet(zc_vector,0,6000.);
  nzc=1;
    
  //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
  //LOOP IN HEIGHTS
  //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
  FILE *ft=fopen("hdw-legacy.dat","w");
  for(zczc=0;zczc<=nzc-1;zczc++){
    zc=VecGet(zc_vector,zczc);
    //Ac=1.-fi*(zc/1000.);
    Ac=0.6;
    resultados=MatAlloc(niterL+1,19);

    //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
    //LOOP IN SOLAR FORCING
    //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
    for(ii=0;ii<=niterL;ii++){
      L = deltaL*ii+Lini;
      printf("%d de %d, L = %.4lf\n",ii,niterL,L);
      
      //valores iniciales
      aclouds = 0.01	;//adimensional, 0 para reproducir modelo original, 0.01 para iniciar con area de nubes
      awhite = 0.01	;//adimensional
      ablack = 0.01	;//adimensional
      Ts=295.5	;//temperatura en la superficie, valor inicial para rk4

      d = t_modelacion ;//numero de años en el eje de las abscisas - iteraciones de t - dimension de los vectores de resultados

      //printf("Tam:%d\n",(int)(d+1)/2);
      time=VecAlloc((d+1)/2);
      temperature=VecAlloc((d+1)/2);
      white_temperature=VecAlloc((d+1)/2);
      black_temperature=VecAlloc((d+1)/2);
      white_area=VecAlloc((d+1)/2);
      black_area=VecAlloc((d+1)/2);
      clouds_area=VecAlloc((d+1)/2);
      evap=VecAlloc((d+1)/2);
      prec=VecAlloc((d+1)/2);

      it=0;
      
      //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      //LOOP IN MODELLING TIME
      //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      for(t=0;t<=t_modelacion;t+=t_integracion){

	//if(it>5000){
	if(it>-1){
	  fprintf(ft,"%e %e %e %e %e\n",
		  t,Ts,aclouds,awhite,ablack);

	}

	xx = pp - awhite - ablack;
	As = xx*Agf + ablack*Ab + awhite*Aw;

	//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
	//TIME INTEGRATION
	//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
	for(j=1;j<=niter;j++){
	  
	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  //TEMPERATURE
	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  k1=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int((Ts+grad_T*zc),4)-sigma*Es*gsl_pow_int(Ts,4));
	  k2=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int(((Ts+k1/2)+grad_T*zc),4)-sigma*Es*gsl_pow_int((Ts+k1/2),4));
	  k3=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int(((Ts+k2/2)+grad_T*zc),4)-sigma*Es*gsl_pow_int((Ts+k2/2),4));
	  k4=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int(((Ts+k3)+grad_T*zc),4)-sigma*Es*gsl_pow_int((Ts+k3),4));
	  Ts = Ts+deltat*(k1/6+k2/3+k3/3+k4/6);

	  //CLOUD TEMPERATURE
	  Tc=Ts+zc*grad_T;
	  Tlb=q*(As-Ab)+Ts;
	  Tlw=q*(As-Aw)+Ts;
	  
	  //EVAPORATION
	  if(Ts>277){
	    Tanual = Ts - 273.	;//(°C)
	    I = 12.*pow((Tanual/5.),1.5);
	    a = (6.7e-7)*gsl_pow_int(I,3) - (7.7e-5)*PowInt(I,2) + (1.8e-2)*I + 0.49;
	    EVP = 12.*16*pow((10.*(Ts - 273.)/I),a);
	    E = Min(1.,EVP/EVPmax);
	  }else{
	    E = 0.;
	  }

	  //PRECIPITATION
	  P = (1./Pmax)*pow((aclouds/mm),(1./nn));

	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  //CLOUD COVERING
	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  k1c=(1-aclouds)*E-aclouds*P;
	  k2c=(1-(aclouds+k1c/2))*E-(aclouds+k1c/2)*P;
	  k3c=(1-(aclouds+k2c/2))*E-(aclouds+k2c/2)*P;
	  k4c=(1-(aclouds+k3c))*E-(aclouds+k3c)*P;
	  aclouds=aclouds+deltat*(k1c/6+k2c/3+k3c/3+k4c/6);

	  //REPRODUCTIVE FITNESS
	  //WHITE DAISIES
	  if((Tlw>278)&&(Tlw<313))
	    Bw=1-0.003265*PowInt((Topt-Tlw),2);
	  else Bw=0;
	  //BLACK DAISIES
	  if((Tlb>278)&&(Tlb<313)) 
	    Bb=1-0.003265*PowInt((Topt-Tlb),2);
	  else Bb=0;
	  
	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  //WHITE AREA
	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  k1w=awhite*(xx*Bw-gamma);
	  k2w=(awhite+k1w/2)*(xx*Bw-gamma);
	  k3w=(awhite+k2w/2)*(xx*Bw-gamma);
	  k4w=(awhite+k3w)*(xx*Bw-gamma);
	  awhite=awhite+deltat*(k1w/6+k2w/3+k3w/3+k4w/6);

	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  //BLACK AREA
	  //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	  k1b=ablack*(xx*Bb-gamma);
	  k2b=(ablack+k1b/2)*(xx*Bb-gamma);
	  k3b=(ablack+k2b/2)*(xx*Bb-gamma);
	  k4b=(ablack+k3b)*(xx*Bb-gamma);
	  ablack=ablack+deltat*(k1b/6+k2b/3+k3b/3+k4b/6);

	  xx = pp - awhite - ablack;
	  As = xx*Agf + ablack*Ab + awhite*Aw;
	  
	}//end for time integration
	
	if(it>5000){
	  VecSet(time,it-5001,t);
	  VecSet(temperature,it-5001,Ts-273);
	  VecSet(white_temperature,it-5001,Tlw-273);
	  VecSet(black_temperature,it-5001,Tlb-273);
	  VecSet(white_area,it-5001,awhite);
	  VecSet(black_area,it-5001,ablack);
	  VecSet(clouds_area,it-5001,aclouds);
	  VecSet(evap,it-5001,E*(1-aclouds));
	  VecSet(prec,it-5001,P*aclouds);
	}
	
	it++;
	
      }//end for modelling time t
      

      if(VERBOSE){
	fprintf(stdout,"Valor %s = %.6e\n",VARS[0],L);
	fprintf(stdout,"Valor %s = %.6e\n",VARS[1],VecMin(temperature))	;//Ts
	fprintf(stdout,"Valor %s = %.6e\n",VARS[2],VecMean(temperature))	;//Ts
	fprintf(stdout,"Valor %s = %.6e\n",VARS[3],VecMax(temperature))	;//Ts
	fprintf(stdout,"Valor %s = %.6e\n",VARS[4],VecMin(white_area))	;//aw
	fprintf(stdout,"Valor %s = %.6e\n",VARS[5],VecMean(white_area))	;//aw
	fprintf(stdout,"Valor %s = %.6e\n",VARS[6],VecMax(white_area))	;//aw
	fprintf(stdout,"Valor %s = %.6e\n",VARS[7],VecMin(black_area))	;//ab
	fprintf(stdout,"Valor %s = %.6e\n",VARS[8],VecMean(black_area))	;//ab
	fprintf(stdout,"Valor %s = %.6e\n",VARS[9],VecMax(black_area))	;//ab
	fprintf(stdout,"Valor %s = %.6e\n",VARS[10],VecMin(clouds_area))	;//ac
	fprintf(stdout,"Valor %s = %.6e\n",VARS[11],VecMean(clouds_area))	;//ac
	fprintf(stdout,"Valor %s = %.6e\n",VARS[12],VecMax(clouds_area))	;//ac
	fprintf(stdout,"Valor %s = %.6e\n",VARS[13],VecMin(evap))	;//E
	fprintf(stdout,"Valor %s = %.6e\n",VARS[14],VecMean(evap))	;//E
	fprintf(stdout,"Valor %s = %.6e\n",VARS[15],VecMax(evap))	;//E
	fprintf(stdout,"Valor %s = %.6e\n",VARS[16],VecMin(prec))	;//P
	fprintf(stdout,"Valor %s = %.6e\n",VARS[17],VecMean(prec))	;//P
	fprintf(stdout,"Valor %s = %.6e\n",VARS[18],VecMax(prec))	;//P
      }
 
      //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      //RESULTADOS
      //&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      MatSet(resultados,ii,0,L);
      MatSet(resultados,ii,1,VecMin(temperature))	;//Ts
      MatSet(resultados,ii,2,VecMean(temperature))	;//Ts
      MatSet(resultados,ii,3,VecMax(temperature))	;//Ts
      MatSet(resultados,ii,4,VecMin(white_area))	;//aw
      MatSet(resultados,ii,5,VecMean(white_area))	;//aw
      MatSet(resultados,ii,6,VecMax(white_area))	;//aw
      MatSet(resultados,ii,7,VecMin(black_area))	;//ab
      MatSet(resultados,ii,8,VecMean(black_area))	;//ab
      MatSet(resultados,ii,9,VecMax(black_area))	;//ab
      MatSet(resultados,ii,10,VecMin(clouds_area))	;//ac
      MatSet(resultados,ii,11,VecMean(clouds_area))	;//ac
      MatSet(resultados,ii,12,VecMax(clouds_area))	;//ac
      MatSet(resultados,ii,13,VecMin(evap))	;//E
      MatSet(resultados,ii,14,VecMean(evap))	;//E
      MatSet(resultados,ii,15,VecMax(evap))	;//E
      MatSet(resultados,ii,16,VecMin(prec))	;//P
      MatSet(resultados,ii,17,VecMean(prec))	;//P
      MatSet(resultados,ii,18,VecMax(prec))	;//P

      VecFree(time);
      VecFree(temperature);
      VecFree(white_temperature);
      VecFree(black_temperature);
      VecFree(white_area);
      VecFree(black_area);
      VecFree(clouds_area);
      VecFree(evap);
      VecFree(prec);

    }//end for ii

    sprintf(fname,"DAWHYC2_EXP2_L0416_%.2f_%d_activa.txt",Ac,(int)zc/1000);
    fl=fopen(fname,"w");
    fprintf(fl,"zc= %.0lf\n",zc);
    fprintf(fl,"Ac= %.2lf\n",Ac);

    for(j=0;j<NVARS;j++)
      fprintf(fl,"%10s ",VARS[j]);

    MatrixFprintf(fl,resultados,"%10.4f ");
    fclose(fl);
    
    MatFree(resultados);

  }//end for heights
  fclose(ft);
  
}//end program
Ejemplo n.º 21
0
static void MakePQ(int n, int mj, int nj)

{
    MatRep_t *rep_m;
    Matrix_t *estar[MAXENDO], *endo[MAXENDO], *e, *ei;
    char fn[200];
    int dim = InfoM.Cf[mj].dim;
    int spl = InfoM.Cf[mj].spl;
    int i;
    Matrix_t *p;

    MESSAGE(1,("Condensing %s%s x ",InfoM.BaseName,Lat_CfName(&InfoM,mj)));
    MESSAGE(1,("%s%s, [E:k]=%d\n",InfoN.BaseName,Lat_CfName(&InfoN,nj),spl));

    /* Read the generators for the constituent of M and make the
       endomorphism ring.
       --------------------------------------------------------- */
    rep_m = Lat_ReadCfGens(&InfoM,mj,InfoM.Cf[mj].peakword >= 0 ? LAT_RG_STD : 0);
    MESSAGE(2,("Calculating endomorphism ring\n"));
    MkEndo(rep_m,InfoM.Cf + mj,endo,MAXENDO);
    MrFree(rep_m);

    /* Calculate the Q matrix
       ---------------------- */
    MESSAGE(2,("Calculating embedding of E\n"));
    MakeQ(n,spl,(const Matrix_t **)endo);
    
    /* Calculate the E* matrices
       Note: We should use the symmetry under i<-->k here!
       --------------------------------------------------- */
    MESSAGE(2,("Calculating projection on E\n"));
    MESSAGE(2,("   E* matrices\n"));
    e = MatAlloc(FfOrder,spl,spl);
    for (i = 0; i < spl; ++i)
    {
	PTR pptr = MatGetPtr(e,i);
	int k;
	for (k = 0; k < spl; ++k)
	{
	    FEL f;
	    Matrix_t *x = MatDup(endo[i]);  
	    MatMul(x,endo[k]);
	    f = MatTrace(x);
	    FfInsert(pptr,k,f);
	    MatFree(x);
	}
    }
    ei = MatInverse(e);
    MatFree(e);

    for (i = 0; i < spl; ++i)
    {
	int k;
	PTR p;
	estar[i] = MatAlloc(FfOrder,dim,dim);
	p = MatGetPtr(ei,i);
	for (k = 0; k < spl; ++k)
	    MatAddMul(estar[i],endo[k],FfExtract(p,k));
    }
    MatFree(ei);

    /* Transpose the E* matrices. This simplifies the 
       calculation of tr(z E*) below.
       ----------------------------------------------- */
    MESSAGE(2,("   Transposing E* matrices\n"));
    for (i = 0; i < spl; ++i)
    {
	Matrix_t *x = MatTransposed(estar[i]);
	MatFree(estar[i]);
	estar[i] = x;
    }

    /* Calculate the P matrix
       ---------------------- */
    MESSAGE(2,("   P matrix\n"));
    p = MatAlloc(FfOrder,dim*dim,spl);
    for (i = 0; i < dim; ++i)
    {
	int j;
	for (j = 0; j < dim; ++j)
	{
	    int r;
	    PTR pptr = MatGetPtr(p,i*dim + j);
	    Matrix_t *x = MatAlloc(FfOrder,dim,dim);
	    MatCopyRegion(x,0,i,Trans[n],0,j,dim,1);
	    for (r = 0; r < spl; ++r)
	    {
		FEL f = MatProd(x,estar[r]);
		FfInsert(pptr,r,f);
	    }
	    MatFree(x);
	}
    }

    sprintf(fn,"%s.p.%d",TkiName,n+1);
    MESSAGE(2,("Writing %s\n",fn));
#if 0
    if (InfoM.Cf[mj].peakword < 0)
	MatMulScalar(p,FF_ZERO);
#endif
    MatSave(p,fn);

    /* Clean up
       -------- */
    MatFree(p);
    for (i = 0; i < spl; ++i)
        MatFree(endo[i]);
}
Ejemplo n.º 22
0
MTX_DEFINE_FILE_INFO

/// @addtogroup mat
/// @{

////////////////////////////////////////////////////////////////////////////////////////////////////
/// Stable power of a matrix.
/// This function takes a square matrix M and finds an integer n>0 such that
/// ker(M<sup>n</sup>) = ker(M<sup>n+1</sup>).
/// @a ker must be a pointer to a variable of type Matrix_t*,
/// where the stable kernel will be stored. Both @a pwr and @a ker may be
/// NULL if the corresponding information is not needed.
///
/// Note that the number $n$ found by StablePower_() is not guararanteed
/// to be minimal. In fact, n will always be a power of two since the
/// function only examines matrices of the form M<sup>2<sup>k</sup></sup>.
///
/// This function modifies the matrix. To avoid this, use StablePower().
/// @param mat The matrix.
/// @param pwr Stable power.
/// @param ker Kernel of the stable power.
/// @return 0 on success, -1 on error.

int StablePower_(Matrix_t *mat, int *pwr, Matrix_t **ker)
{
   // check the arguments.
   if (!MatIsValid(mat)) {
      MTX_ERROR1("mat: %E",MTX_ERR_BADARG);
      return -1;
   }
   if (mat->Nor != mat->Noc) {
      MTX_ERROR1("%E",MTX_ERR_NOTSQUARE);
      return -1;
   }

   // calculate the stable power
   int p = 1;
   Matrix_t *k1 = MatNullSpace(mat);
   if (k1 == NULL) {
       return -1;
   }
   if (MatMul(mat,mat) == NULL) {
       MatFree(k1);
       return -1;
   }
   Matrix_t *k2 = MatNullSpace(mat);
   if (k2 == NULL) {
       MatFree(k1);
       return -1;
   }

   while (k2->Nor > k1->Nor) {
      p *= 2;
      MatFree(k1);
      k1 = k2;
      if (MatMul(mat,mat) == NULL) {
         MatFree(k1);
         return -1;
      }
      k2 = MatNullSpace(mat);
      if (k2 == NULL) {
         MatFree(k1);
         return -1;
      }
   }
   MatFree(k2);

   // return the result
   if (ker != NULL) {
      *ker = k1;
   } else {
      MatFree(k1);
   }
   if (pwr != NULL) {
      *pwr = p;
   }

   return 0;
}
Ejemplo n.º 23
0
MTX_DEFINE_FILE_INFO

/// @addtogroup spinup
/// @{

////////////////////////////////////////////////////////////////////////////////////////////////////
/// Projection on quotient.
/// This function calculates the projection of a matrix onto the quotient by a
/// subspace. The first matrix, @a subspace must be in echelon form, while the
/// second argument can be any matrix. Of course both matrices must be over the
/// same field and have the same number of columns. The return value is a
/// pointer to a matrix containing the projections the @a vectors. This matrix
/// is not in echelon form and may even contain null rows.
///
/// The projection depends on the basis for the subspace and is calculated as
/// follows. Let V=F<sup>n×n</sup> and (w<sub>1</sub>,...w<sub>s</sub>) be a basis
/// for the subspace W≤V. The basis, written as a matrix of row vectors,
/// is assumed to be in semi-echelon form. By looking at the pivot columns we
/// can construct the vectors w<sub>s+1</sub>,...w<sub>n</sub> by taking all vectors which
/// have a exactly one 1 at any non-pivot position and are zero otherwise.
/// Then, (w<sub>1</sub>,...,w<sub>s</sub>,w<sub>s+1</sub>,...,w<sub>n</sub>)
/// is a basis for V in semi-echelon form and defines the decomposition of any
/// vector into subspace and quotient part.
///
/// @param subspace The invariant subspace.
/// @param vectors The vectors to project.
/// @return Projection of @a vectors on the quotient by @a subspace, or NULL on error.

Matrix_t *QProjection(const Matrix_t *subspace, const Matrix_t *vectors)
{
   int i, sdim, qdim;
   int *non_piv;
   Matrix_t *result;
   PTR tmp;

   // Check the arguments
   if (!MatIsValid(subspace) || !MatIsValid(vectors)) {
      return NULL;
   }
   if ((subspace->Field != vectors->Field) || (subspace->Noc != vectors->Noc)) {
      MTX_ERROR1("%E",MTX_ERR_INCOMPAT);
      return NULL;
   }
   if (subspace->PivotTable == NULL) {
      MTX_ERROR1("%E",MTX_ERR_NOTECH);
      return NULL;
   }

   // Initialize
   sdim = subspace->Nor;
   qdim = subspace->Noc - sdim;
   result = MatAlloc(subspace->Field,vectors->Nor,qdim);
   if (result == NULL) {
       return NULL;
   }

   // Calculate the projection
   FfSetNoc(subspace->Noc);
   tmp = FfAlloc(1);
   if (tmp == NULL) {
       MatFree(result);
       return NULL;
   }
   non_piv = subspace->PivotTable + subspace->Nor;
   for (i = 0; i < vectors->Nor; ++i) {
      int k;
      PTR q = MatGetPtr(result,i);
      MTX_FAIL_IF_NOT(q != NULL);
      FfCopyRow(tmp,MatGetPtr(vectors,i));
      FfCleanRow(tmp,subspace->Data,sdim,subspace->PivotTable);
      for (k = 0; k < qdim; ++k) {
         FfInsert(q,k,FfExtract(tmp,non_piv[k]));
      }
   }
   SysFree(tmp);

   return result;
}