static PetscErrorCode PetscFormatRealArray(char buf[],size_t len,const char *fmt,PetscInt n,const PetscReal x[])
{
PetscErrorCode ierr;
PetscInt i;
size_t left,count;
char *p;
PetscFunctionBegin;
for (i=0,p=buf,left=len; i<n; i++) {
ierr = PetscSNPrintfCount(p,left,fmt,&count,x[i]);CHKERRQ(ierr);
if (count >= left) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_OUTOFRANGE,"Insufficient space in buffer");
left -= count;
p += count;
*p++ = ' ';
}
p[i ? 0 : -1] = 0;
PetscFunctionReturn(0);
}
static PetscErrorCode PCSetUp_SVD(PC pc)
{
#if defined(PETSC_MISSING_LAPACK_GESVD)
SETERRQ(PetscObjectComm((PetscObject)pc),PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable\nNot able to provide singular value estimates.");
#else
PC_SVD *jac = (PC_SVD*)pc->data;
PetscErrorCode ierr;
PetscScalar *a,*u,*v,*d,*work;
PetscBLASInt nb,lwork;
PetscInt i,n;
PetscMPIInt size;
PetscFunctionBegin;
ierr = MatDestroy(&jac->A);CHKERRQ(ierr);
ierr = MPI_Comm_size(((PetscObject)pc->pmat)->comm,&size);CHKERRQ(ierr);
if (size > 1) {
Mat redmat;
PetscInt M;
ierr = MatGetSize(pc->pmat,&M,NULL);CHKERRQ(ierr);
ierr = MatGetRedundantMatrix(pc->pmat,size,PETSC_COMM_SELF,M,MAT_INITIAL_MATRIX,&redmat);CHKERRQ(ierr);
ierr = MatConvert(redmat,MATSEQDENSE,MAT_INITIAL_MATRIX,&jac->A);CHKERRQ(ierr);
ierr = MatDestroy(&redmat);CHKERRQ(ierr);
} else {
ierr = MatConvert(pc->pmat,MATSEQDENSE,MAT_INITIAL_MATRIX,&jac->A);CHKERRQ(ierr);
}
if (!jac->diag) { /* assume square matrices */
ierr = MatGetVecs(jac->A,&jac->diag,&jac->work);CHKERRQ(ierr);
}
if (!jac->U) {
ierr = MatDuplicate(jac->A,MAT_DO_NOT_COPY_VALUES,&jac->U);CHKERRQ(ierr);
ierr = MatDuplicate(jac->A,MAT_DO_NOT_COPY_VALUES,&jac->Vt);CHKERRQ(ierr);
}
ierr = MatGetSize(pc->pmat,&n,NULL);CHKERRQ(ierr);
ierr = PetscBLASIntCast(n,&nb);CHKERRQ(ierr);
lwork = 5*nb;
ierr = PetscMalloc(lwork*sizeof(PetscScalar),&work);CHKERRQ(ierr);
ierr = MatDenseGetArray(jac->A,&a);CHKERRQ(ierr);
ierr = MatDenseGetArray(jac->U,&u);CHKERRQ(ierr);
ierr = MatDenseGetArray(jac->Vt,&v);CHKERRQ(ierr);
ierr = VecGetArray(jac->diag,&d);CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
{
PetscBLASInt lierr;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
PetscStackCall("LAPACKgesvd",LAPACKgesvd_("A","A",&nb,&nb,a,&nb,d,u,&nb,v,&nb,work,&lwork,&lierr));
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"gesv() error %d",lierr);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
}
#else
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not coded for complex");
#endif
ierr = MatDenseRestoreArray(jac->A,&a);CHKERRQ(ierr);
ierr = MatDenseRestoreArray(jac->U,&u);CHKERRQ(ierr);
ierr = MatDenseRestoreArray(jac->Vt,&v);CHKERRQ(ierr);
for (i=n-1; i>=0; i--) if (PetscRealPart(d[i]) > jac->zerosing) break;
jac->nzero = n-1-i;
if (jac->monitor) {
ierr = PetscViewerASCIIAddTab(jac->monitor,((PetscObject)pc)->tablevel);CHKERRQ(ierr);
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: condition number %14.12e, %D of %D singular values are (nearly) zero\n",(double)PetscRealPart(d[0]/d[n-1]),jac->nzero,n);CHKERRQ(ierr);
if (n >= 10) { /* print 5 smallest and 5 largest */
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: smallest singular values: %14.12e %14.12e %14.12e %14.12e %14.12e\n",(double)PetscRealPart(d[n-1]),(double)PetscRealPart(d[n-2]),(double)PetscRealPart(d[n-3]),(double)PetscRealPart(d[n-4]),(double)PetscRealPart(d[n-5]));CHKERRQ(ierr);
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: largest singular values : %14.12e %14.12e %14.12e %14.12e %14.12e\n",(double)PetscRealPart(d[4]),(double)PetscRealPart(d[3]),(double)PetscRealPart(d[2]),(double)PetscRealPart(d[1]),(double)PetscRealPart(d[0]));CHKERRQ(ierr);
} else { /* print all singular values */
char buf[256],*p;
size_t left = sizeof(buf),used;
PetscInt thisline;
for (p=buf,i=n-1,thisline=1; i>=0; i--,thisline++) {
ierr = PetscSNPrintfCount(p,left," %14.12e",&used,(double)PetscRealPart(d[i]));CHKERRQ(ierr);
left -= used;
p += used;
if (thisline > 4 || i==0) {
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: singular values:%s\n",buf);CHKERRQ(ierr);
p = buf;
thisline = 0;
}
}
}
ierr = PetscViewerASCIISubtractTab(jac->monitor,((PetscObject)pc)->tablevel);CHKERRQ(ierr);
}
ierr = PetscInfo2(pc,"Largest and smallest singular values %14.12e %14.12e\n",(double)PetscRealPart(d[0]),(double)PetscRealPart(d[n-1]));CHKERRQ(ierr);
for (i=0; i<n-jac->nzero; i++) d[i] = 1.0/d[i];
for (; i<n; i++) d[i] = 0.0;
if (jac->essrank > 0) for (i=0; i<n-jac->nzero-jac->essrank; i++) d[i] = 0.0; /* Skip all but essrank eigenvalues */
ierr = PetscInfo1(pc,"Number of zero or nearly singular values %D\n",jac->nzero);CHKERRQ(ierr);
ierr = VecRestoreArray(jac->diag,&d);CHKERRQ(ierr);
#if defined(foo)
{
PetscViewer viewer;
ierr = PetscViewerBinaryOpen(PETSC_COMM_SELF,"joe",FILE_MODE_WRITE,&viewer);CHKERRQ(ierr);
ierr = MatView(jac->A,viewer);CHKERRQ(ierr);
ierr = MatView(jac->U,viewer);CHKERRQ(ierr);
ierr = MatView(jac->Vt,viewer);CHKERRQ(ierr);
ierr = VecView(jac->diag,viewer);CHKERRQ(ierr);
ierr = PetscViewerDestroy(viewer);CHKERRQ(ierr);
}
#endif
ierr = PetscFree(work);CHKERRQ(ierr);
PetscFunctionReturn(0);
#endif
}
