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;
}