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); }
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); }
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); }
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; }
/*******************************+++*******************************/ 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); }
Matrix_t *MatNullSpace__(Matrix_t *mat) { Matrix_t *nsp; nsp = MatNullSpace_(mat,0); MatFree(mat); return nsp; }
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; }
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); }
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; }
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; }
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; }
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; }
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; }
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; }
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); } }
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; }
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); }
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); }
/*******************************+++*******************************/ 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; }
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
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]); }
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; }
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; }