/* Overwrites A. Can only handle full-rank problems with m>=n
* A in column-major format
* Ainv in row-major format
* tau has length m
* worksize must be >= max(1,n)
*/
static PetscErrorCode PetscDTPseudoInverseQR(PetscInt m,PetscInt mstride,PetscInt n,PetscReal *A_in,PetscReal *Ainv_out,PetscScalar *tau,PetscInt worksize,PetscScalar *work)
{
PetscErrorCode ierr;
PetscBLASInt M,N,K,lda,ldb,ldwork,info;
PetscScalar *A,*Ainv,*R,*Q,Alpha;
PetscFunctionBegin;
#if defined(PETSC_USE_COMPLEX)
{
PetscInt i,j;
ierr = PetscMalloc2(m*n,PetscScalar,&A,m*n,PetscScalar,&Ainv);CHKERRQ(ierr);
for (j=0; j<n; j++) {
for (i=0; i<m; i++) A[i+m*j] = A_in[i+mstride*j];
}
mstride = m;
}
#else
A = A_in;
Ainv = Ainv_out;
#endif
ierr = PetscBLASIntCast(m,&M);CHKERRQ(ierr);
ierr = PetscBLASIntCast(n,&N);CHKERRQ(ierr);
ierr = PetscBLASIntCast(mstride,&lda);CHKERRQ(ierr);
ierr = PetscBLASIntCast(worksize,&ldwork);CHKERRQ(ierr);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
LAPACKgeqrf_(&M,&N,A,&lda,tau,work,&ldwork,&info);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xGEQRF error");
R = A; /* Upper triangular part of A now contains R, the rest contains the elementary reflectors */
/* Extract an explicit representation of Q */
Q = Ainv;
ierr = PetscMemcpy(Q,A,mstride*n*sizeof(PetscScalar));CHKERRQ(ierr);
K = N; /* full rank */
LAPACKungqr_(&M,&N,&K,Q,&lda,tau,work,&ldwork,&info);
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xORGQR/xUNGQR error");
/* Compute A^{-T} = (R^{-1} Q^T)^T = Q R^{-T} */
Alpha = 1.0;
ldb = lda;
BLAStrsm_("Right","Upper","ConjugateTranspose","NotUnitTriangular",&M,&N,&Alpha,R,&lda,Q,&ldb);
/* Ainv is Q, overwritten with inverse */
#if defined(PETSC_USE_COMPLEX)
{
PetscInt i;
for (i=0; i<m*n; i++) Ainv_out[i] = PetscRealPart(Ainv[i]);
ierr = PetscFree2(A,Ainv);CHKERRQ(ierr);
}
#endif
PetscFunctionReturn(0);
}
int getQ1(Mat *pA){
int i,j;
PetscInt m,n;
PetscBLASInt M,N,K,lda,ldwork,info;
PetscScalar *tau,*work;
PetscInt worksize;
PetscErrorCode ierr;
ierr = MatGetSize(*pA,&m,&n);CHKERRQ(ierr);
PetscBLASIntCast(m,&M);
PetscBLASIntCast(n,&N);
worksize=m;
PetscBLASIntCast(worksize,&ldwork);
PetscMalloc1(m, &tau);//worksize,&work);
PetscMalloc1(worksize,&work);
K = N; /*full rank*/
lda = M ; //N - row domain M - col domain
//ierr = PetscPrintf (PETSC_COMM_SELF,"L72\n");CHKERRQ(ierr);
//ierr = MatView(*pA,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"L74\n");CHKERRQ(ierr);
PetscScalar *v;//[4]={0};
PetscInt *Is; //[4]={0,1,2,3};
PetscInt nC;// = 4;
PetscReal arr[10*4];
for(i=0; i<10; i++){
ierr = MatGetRow(*pA,i,&nC,(const PetscInt **)&Is,(const PetscScalar **)&v); CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"get row %d %d\n", i, nC);CHKERRQ(ierr);
for(j=0; j<nC; j++){
arr[i+10*Is[j]]=v[j];
}
ierr = MatRestoreRow(*pA,i,&nC,(const PetscInt**)&Is,(const PetscScalar**)&v); CHKERRQ(ierr);
}
//ierr = PetscPrintf (PETSC_COMM_SELF,"new L72\n");CHKERRQ(ierr);
//ierr = MatView(*pA,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"new L74\n");CHKERRQ(ierr);
//for(i=0;i<40; i++){
// ierr = PetscPrintf (PETSC_COMM_SELF,"arr[%d] = %f\n",i,arr[i]);CHKERRQ(ierr);
//}
/* Do QR */
PetscFPTrapPush(PETSC_FP_TRAP_OFF);
LAPACKgeqrf_(&M,&N,arr,&lda,tau,work,&ldwork,&info);
PetscFPTrapPop();
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xGEQRF error");
/*Extract an explicit representation of Q */
//PetscMemcpy(Q,A,mstride*n*sizeof(PetscScalar));
LAPACKungqr_(&M,&N,&K,arr,&lda,tau,work,&ldwork,&info);
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xORGQR/xUNGQR error");
//ierr = PetscPrintf (PETSC_COMM_SELF,"\nWe store Q1 in arr:\n");CHKERRQ(ierr);
//for(i=0;i<40; i++){
// ierr = PetscPrintf (PETSC_COMM_SELF,"arr[%d] = %f\n",i,arr[i]);CHKERRQ(ierr);
//}
for (i=0; i<10; i++) {
for(j=0; j<4; j++) {
ierr = MatSetValues(*pA,1,&i,1,&j,&arr[i+j*10],INSERT_VALUES);CHKERRQ(ierr);
}
}
ierr = MatAssemblyBegin(*pA,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(*pA,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"\nThe Q1 we are going to return is\n");CHKERRQ(ierr);
//ierr = MatView(*pA,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr);
//ierr = PetscFree(arr);CHKERRQ(ierr);
return 0;
}
static PetscErrorCode KSPAGMRESBuildSoln(KSP ksp,PetscInt it)
{
KSP_AGMRES *agmres = (KSP_AGMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt max_k = agmres->max_k; /* Size of the non-augmented Krylov basis */
PetscInt i, j;
PetscInt r = agmres->r; /* current number of augmented eigenvectors */
PetscBLASInt KspSize;
PetscBLASInt lC;
PetscBLASInt N;
PetscBLASInt ldH = N + 1;
PetscBLASInt lwork;
PetscBLASInt info, nrhs = 1;
PetscFunctionBegin;
ierr = PetscBLASIntCast(KSPSIZE,&KspSize);CHKERRQ(ierr);
ierr = PetscBLASIntCast(4 * (KspSize+1),&lwork);CHKERRQ(ierr);
ierr = PetscBLASIntCast(KspSize+1,&lC);CHKERRQ(ierr);
ierr = PetscBLASIntCast(MAXKSPSIZE + 1,&N);CHKERRQ(ierr);
ierr = PetscBLASIntCast(N + 1,&ldH);CHKERRQ(ierr);
/* Save a copy of the Hessenberg matrix */
for (j = 0; j < N-1; j++) {
for (i = 0; i < N; i++) {
*HS(i,j) = *H(i,j);
}
}
/* QR factorize the Hessenberg matrix */
#if defined(PETSC_MISSING_LAPACK_GEQRF)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEQRF - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&lC, &KspSize, agmres->hh_origin, &ldH, agmres->tau, agmres->work, &lwork, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XGEQRF INFO=%d", info);
#endif
/* Update the right hand side of the least square problem */
ierr = PetscMemzero(agmres->nrs, N*sizeof(PetscScalar));CHKERRQ(ierr);
agmres->nrs[0] = ksp->rnorm;
#if defined(PETSC_MISSING_LAPACK_ORMQR)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEQRF - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKormqr",LAPACKormqr_("L", "T", &lC, &nrhs, &KspSize, agmres->hh_origin, &ldH, agmres->tau, agmres->nrs, &N, agmres->work, &lwork, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XORMQR INFO=%d",info);
#endif
ksp->rnorm = PetscAbsScalar(agmres->nrs[KspSize]);
/* solve the least-square problem */
#if defined(PETSC_MISSING_LAPACK_TRTRS)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"TRTRS - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U", "N", "N", &KspSize, &nrhs, agmres->hh_origin, &ldH, agmres->nrs, &N, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XTRTRS INFO=%d",info);
#endif
/* Accumulate the correction to the solution of the preconditioned problem in VEC_TMP */
ierr = VecZeroEntries(VEC_TMP);CHKERRQ(ierr);
ierr = VecMAXPY(VEC_TMP, max_k, agmres->nrs, &VEC_V(0));CHKERRQ(ierr);
if (!agmres->DeflPrecond) { ierr = VecMAXPY(VEC_TMP, r, &agmres->nrs[max_k], agmres->U);CHKERRQ(ierr); }
if ((ksp->pc_side == PC_RIGHT) && agmres->r && agmres->DeflPrecond) {
ierr = KSPDGMRESApplyDeflation_DGMRES(ksp, VEC_TMP, VEC_TMP_MATOP);CHKERRQ(ierr);
ierr = VecCopy(VEC_TMP_MATOP, VEC_TMP);CHKERRQ(ierr);
}
ierr = KSPUnwindPreconditioner(ksp, VEC_TMP, VEC_TMP_MATOP);CHKERRQ(ierr);
/* add the solution to the previous one */
ierr = VecAXPY(ksp->vec_sol, 1.0, VEC_TMP);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
