/***********************************************************//**
Free memory allocated to array of QR structures
\param[in,out] qr - array to free
\param[in] n - number of QR structures
***************************************************************/
void qr_array_free(struct QR ** qr, size_t n)
{
if (qr != NULL){
size_t ii;
for (ii = 0; ii < n; ii++){
qr_free(qr[ii]); qr[ii] = NULL;
}
free(qr); qr = NULL;
}
}
int main(void)
{
// bugfix for comma in floating point outputs with printf
gtk_disable_setlocale();
gtk_init(NULL, NULL);
gtk_window_init();
gtk_main();
qr_free();
return 0;
}
/***********************************************************//**
Perform a right-left dmrg sweep as part of ft-product
\param[in] z - initial guess
\param[in] f - specialized function to multiply core by matrix
\param[in] args - arguments to f
\param[in,out] phil - left multipliers
\param[in] psir - right multiplies
\param[in] epsilon - splitting tolerance
\param[in] opts - approximation options
\return na - a new approximation
***************************************************************/
struct FunctionTrain *
dmrg_sweep_rl(struct FunctionTrain * z,
void (*f)(char,size_t,size_t,double *,struct Qmarray **,void *),
void * args, struct QR ** phil, struct QR ** psir, double epsilon,
struct MultiApproxOpts * opts)
{
double * RL = NULL;
size_t dim = z->dim;
struct FunctionTrain * na = function_train_alloc(dim);
na->ranks[0] = 1;
na->ranks[na->dim] = 1;
struct OneApproxOpts * o = NULL;
if (psir[dim-2] == NULL){
struct Qmarray * temp0 = NULL;
f('R',dim-1,1,NULL,&temp0,args);
//qmarray_kron(a->cores[dim-1],b->cores[dim-1]);
o = multi_approx_opts_get_aopts(opts,dim-1);
psir[dim-2] = qr_reduced(temp0,0,o);
qmarray_free(temp0); temp0 = NULL;
}
size_t nrows = phil[dim-2]->mr;
size_t nmult = phil[dim-2]->mc;
size_t ncols = psir[dim-2]->mc;
RL = calloc_double(nrows * ncols);
cblas_dgemm(CblasColMajor,CblasNoTrans,CblasNoTrans,nrows,ncols,
nmult,1.0,phil[dim-2]->mat,nrows,psir[dim-2]->mat,nmult,0.0,RL,nrows);
double * u = NULL;
double * vt = NULL;
double * s = NULL;
/* printf("Right-Left sweep\n"); */
/* printf("(nrows,ncols)=(%zu,%zu), epsilon=%G\n",nrows,ncols,epsilon); */
size_t rank = truncated_svd(nrows,ncols,nrows,RL,&u,&s,&vt,epsilon);
/* printf("rank=%zu\n",rank); */
na->ranks[dim-1] = rank;
na->cores[dim-1] = mqma(vt,psir[dim-2]->Q,rank);
int ii;
for (ii = dim-3; ii > -1; ii--){
double * newpsi = calloc_double( psir[ii+1]->mr * rank);
//
cblas_dgemm(CblasColMajor,CblasNoTrans,CblasTrans,
psir[ii+1]->mr,rank, psir[ii+1]->mc,
1.0,psir[ii+1]->mat,psir[ii+1]->mr,vt,rank,
0.0,newpsi,psir[ii+1]->mr);
struct Qmarray * temp = NULL;
// qmarray_kron_mat(rank,newpsi,a->cores[ii+1],b->cores[ii+1]);
f('R',(size_t)ii+1,rank,newpsi,&temp,args);
qr_free(psir[ii]); psir[ii] = NULL;
o = multi_approx_opts_get_aopts(opts,(size_t)ii+1);
psir[ii] = qr_reduced(temp,0,o);
free(RL); RL = NULL;
free(newpsi); newpsi = NULL;
free(u); u = NULL;
free(vt); vt = NULL;
free(s); s = NULL;
qmarray_free(temp); temp = NULL;
nrows = phil[ii]->mr;
nmult = phil[ii]->mc;
ncols = psir[ii]->mc;
RL = calloc_double(nrows * ncols);
cblas_dgemm(CblasColMajor,CblasNoTrans,CblasNoTrans,nrows,ncols,
nmult,1.0,phil[ii]->mat,nrows,psir[ii]->mat,nmult,0.0,RL,nrows);
/* printf("(nrows,ncols)=(%zu,%zu), epsilon=%G\n",nrows,ncols,epsilon); */
rank = truncated_svd(nrows,ncols,nrows,RL,&u,&s,&vt,epsilon);
/* printf("rank=%zu\n",rank); */
na->ranks[ii+1] = rank;
na->cores[ii+1] = mqma(vt,psir[ii]->Q,rank);
}
size_t kk,jj;
for (jj = 0; jj < rank; jj++){
for (kk = 0; kk < nrows; kk++){
u[jj*nrows+kk] = u[jj*nrows+kk]*s[jj];
}
}
na->cores[0] = qmam(phil[0]->Q,u,rank);
/* exit(1); */
free(RL); RL = NULL;
free(u); u = NULL;
free(vt); vt = NULL;
free(s); s = NULL;
return na;
}
/***********************************************************//**
Perform a left-right dmrg sweep
\param[in] z - initial guess
\param[in] f - specialized function to multiply core by matrix
\param[in] args - arguments to f
\param[in,out] phil - left multipliers
\param[in] psir - right multiplies
\param[in] epsilon - splitting tolerance
\param[in] opts - approximation options
\return na - a new approximation
***************************************************************/
struct FunctionTrain *
dmrg_sweep_lr(struct FunctionTrain * z,
void (*f)(char,size_t,size_t, double *, struct Qmarray **, void *),
void * args, struct QR ** phil, struct QR ** psir, double epsilon,
struct MultiApproxOpts * opts)
{
double * RL = NULL;
size_t dim = z->dim;
struct FunctionTrain * na = function_train_alloc(dim);
struct OneApproxOpts * o = NULL;
na->ranks[0] = 1;
na->ranks[na->dim] = 1;
if (phil[0] == NULL){
struct Qmarray * temp0 = NULL;
f('L',0,1,NULL,&temp0,args);
/* printf("temp0 size(%zu,%zu) \n",temp0->nrows,temp0->ncols); */
o = multi_approx_opts_get_aopts(opts,0);
phil[0] = qr_reduced(temp0,1,o);
qmarray_free(temp0); temp0 = NULL;
}
/* exit(1); */
size_t nrows = phil[0]->mr;
size_t nmult = phil[0]->mc;
size_t ncols = psir[0]->mc;
RL = calloc_double(nrows * ncols);
cblas_dgemm(CblasColMajor,CblasNoTrans,CblasNoTrans,nrows,ncols,
nmult,1.0,phil[0]->mat,nrows,psir[0]->mat,nmult,0.0,RL,nrows);
double * u = NULL;
double * vt = NULL;
double * s = NULL;
/* printf("Left-Right sweep\n"); */
/* printf("(nrows,ncols)=(%zu,%zu), epsilon=%G\n",nrows,ncols,epsilon); */
size_t rank = truncated_svd(nrows,ncols,nrows,RL,&u,&s,&vt,epsilon);
/* printf("rank=%zu\n",rank); */
na->ranks[1] = rank;
na->cores[0] = qmam(phil[0]->Q,u,rank);
size_t ii;
for (ii = 1; ii < dim-1; ii++){
/* printf("ii = %zu\n",ii); */
double * newphi = calloc_double(rank * phil[ii-1]->mc);
cblas_dgemm(CblasColMajor,CblasTrans,CblasNoTrans,rank,nmult,
nrows,1.0,u,nrows,phil[ii-1]->mat,nrows,0.0,newphi,rank);
//struct Qmarray * temp = mqma(newphi,y->cores[ii],rank);
//struct Qmarray * temp = qmarray_mat_kron(rank,newphi,a->cores[ii],b->cores[ii]);
struct Qmarray * temp = NULL;
f('L',ii,rank,newphi,&temp,args);
qr_free(phil[ii]); phil[ii] = NULL;
o = multi_approx_opts_get_aopts(opts,ii);
phil[ii] = qr_reduced(temp,1,o);
free(RL); RL = NULL;
free(newphi); newphi = NULL;
free(u); u = NULL;
free(vt); vt = NULL;
free(s); s = NULL;
qmarray_free(temp); temp = NULL;
nrows = phil[ii]->mr;
nmult = phil[ii]->mc;
ncols = psir[ii]->mc;
RL = calloc_double(nrows * ncols);
cblas_dgemm(CblasColMajor,CblasNoTrans,CblasNoTrans,nrows,ncols,
nmult,1.0,phil[ii]->mat,nrows,psir[ii]->mat,nmult,0.0,RL,nrows);
/* printf("(nrows,ncols)=(%zu,%zu), epsilon=%G\n",nrows,ncols,epsilon); */
rank = truncated_svd(nrows,ncols,nrows,RL,&u,&s,&vt,epsilon);
/* dprint(nrows,s); */
/* printf("rank=%zu\n",rank); */
na->ranks[ii+1] = rank;
na->cores[ii] = qmam(phil[ii]->Q,u,rank);
}
/* exit(1); */
size_t kk,jj;
for (kk = 0; kk < ncols; kk++){
for (jj = 0; jj < rank; jj++){
vt[kk*rank+jj] = vt[kk*rank+jj]*s[jj];
}
}
na->cores[dim-1] = mqma(vt,psir[dim-2]->Q,rank);
free(RL); RL = NULL;
free(u); u = NULL;
free(vt); vt = NULL;
free(s); s = NULL;
return na;
}