/**************************************xyt.c***********************************/ static PetscErrorCode do_xyt_solve(xyt_ADT xyt_handle, PetscScalar *uc) { PetscInt off, len, *iptr; PetscInt level =xyt_handle->level; PetscInt n =xyt_handle->info->n; PetscInt m =xyt_handle->info->m; PetscInt *stages =xyt_handle->info->stages; PetscInt *xcol_indices=xyt_handle->info->xcol_indices; PetscInt *ycol_indices=xyt_handle->info->ycol_indices; PetscScalar *x_ptr, *y_ptr, *uu_ptr; PetscScalar *solve_uu=xyt_handle->info->solve_uu; PetscScalar *solve_w =xyt_handle->info->solve_w; PetscScalar *x =xyt_handle->info->x; PetscScalar *y =xyt_handle->info->y; PetscBLASInt i1 = 1,dlen; PetscErrorCode ierr; PetscFunctionBegin; uu_ptr=solve_uu; PCTFS_rvec_zero(uu_ptr,m); /* x = X.Y^T.b */ /* uu = Y^T.b */ for (y_ptr=y,iptr=ycol_indices; *iptr!=-1; y_ptr+=len) { off =*iptr++; len =*iptr++; ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr); PetscStackCall("BLASdot",*uu_ptr++ = BLASdot_(&dlen,uc+off,&i1,y_ptr,&i1)); } /* comunication of beta */ uu_ptr=solve_uu; if (level) PCTFS_ssgl_radd(uu_ptr, solve_w, level, stages); PCTFS_rvec_zero(uc,n); /* x = X.uu */ for (x_ptr=x,iptr=xcol_indices; *iptr!=-1; x_ptr+=len) { off =*iptr++; len =*iptr++; ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr); PetscStackCall("BLASaxpy",BLASaxpy_(&dlen,uu_ptr++,x_ptr,&i1,uc+off,&i1)); } PetscFunctionReturn(0); }
PetscErrorCode DSFunction_EXP_NHEP_PADE(DS ds) { #if defined(PETSC_MISSING_LAPACK_GESV) || defined(SLEPC_MISSING_LAPACK_LANGE) PetscFunctionBegin; SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GESV/LANGE - Lapack routines are unavailable"); #else PetscErrorCode ierr; PetscBLASInt n,ld,ld2,*ipiv,info,inc=1; PetscInt j,k,odd; const PetscInt p=MAX_PADE; PetscReal c[MAX_PADE+1],s; PetscScalar scale,mone=-1.0,one=1.0,two=2.0,zero=0.0; PetscScalar *A,*A2,*Q,*P,*W,*aux; PetscFunctionBegin; ierr = PetscBLASIntCast(ds->n,&n);CHKERRQ(ierr); ierr = PetscBLASIntCast(ds->ld,&ld);CHKERRQ(ierr); ld2 = ld*ld; ierr = DSAllocateWork_Private(ds,0,ld,ld);CHKERRQ(ierr); ipiv = ds->iwork; if (!ds->mat[DS_MAT_W]) { ierr = DSAllocateMat_Private(ds,DS_MAT_W);CHKERRQ(ierr); } if (!ds->mat[DS_MAT_Z]) { ierr = DSAllocateMat_Private(ds,DS_MAT_Z);CHKERRQ(ierr); } A = ds->mat[DS_MAT_A]; A2 = ds->mat[DS_MAT_Z]; Q = ds->mat[DS_MAT_Q]; P = ds->mat[DS_MAT_F]; W = ds->mat[DS_MAT_W]; /* Pade' coefficients */ c[0] = 1.0; for (k=1;k<=p;k++) { c[k] = c[k-1]*(p+1-k)/(k*(2*p+1-k)); } /* Scaling */ s = LAPACKlange_("I",&n,&n,A,&ld,ds->rwork); if (s>0.5) { s = PetscMax(0,(int)(PetscLogReal(s)/PetscLogReal(2.0)) + 2); scale = PetscPowReal(2.0,(-1)*s); PetscStackCallBLAS("BLASscal",BLASscal_(&ld2,&scale,A,&inc)); } /* Horner evaluation */ PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&n,&n,&one,A,&ld,A,&ld,&zero,A2,&ld)); ierr = PetscMemzero(Q,ld*ld*sizeof(PetscScalar));CHKERRQ(ierr); ierr = PetscMemzero(P,ld*ld*sizeof(PetscScalar));CHKERRQ(ierr); for (j=0;j<n;j++) { Q[j+j*ld] = c[p]; P[j+j*ld] = c[p-1]; } odd = 1; for (k=p-1;k>0;k--) { if (odd==1) { PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&n,&n,&one,Q,&ld,A2,&ld,&zero,W,&ld)); aux = Q; Q = W; W = aux; for (j=0;j<n;j++) Q[j+j*ld] = Q[j+j*ld] + c[k-1]; } else { PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&n,&n,&one,P,&ld,A2,&ld,&zero,W,&ld)); aux = P; P = W; W = aux; for (j=0;j<n;j++) P[j+j*ld] = P[j+j*ld] + c[k-1]; } odd = 1-odd; } if (odd==1) { PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&n,&n,&one,Q,&ld,A,&ld,&zero,W,&ld)); aux = Q; Q = W; W = aux; PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&ld2,&mone,P,&inc,Q,&inc)); PetscStackCallBLAS("LAPACKgesv",LAPACKgesv_(&n,&n,Q,&ld,ipiv,P,&ld,&info)); PetscStackCallBLAS("BLASscal",BLASscal_(&ld2,&two,P,&inc)); for (j=0;j<n;j++) P[j+j*ld] = P[j+j*ld] + 1.0; PetscStackCallBLAS("BLASscal",BLASscal_(&ld2,&mone,P,&inc)); } else { PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&n,&n,&one,P,&ld,A,&ld,&zero,W,&ld)); aux = P; P = W; W = aux; PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&ld2,&mone,P,&inc,Q,&inc)); PetscStackCallBLAS("LAPACKgesv",LAPACKgesv_(&n,&n,Q,&ld,ipiv,P,&ld,&info)); PetscStackCallBLAS("BLASscal",BLASscal_(&ld2,&two,P,&inc)); for (j=0;j<n;j++) P[j+j*ld] = P[j+j*ld] + 1.0; } for (k=1;k<=s;k++) { PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&n,&n,&one,P,&ld,P,&ld,&zero,W,&ld)); ierr = PetscMemcpy(P,W,ld2*sizeof(PetscScalar));CHKERRQ(ierr); } if (P!=ds->mat[DS_MAT_F]) { ierr = PetscMemcpy(ds->mat[DS_MAT_F],P,ld2*sizeof(PetscScalar));CHKERRQ(ierr); } PetscFunctionReturn(0); #endif }
/**************************************xyt.c***********************************/ static PetscInt xyt_generate(xyt_ADT xyt_handle) { PetscInt i,j,k,idx; PetscInt dim, col; PetscScalar *u, *uu, *v, *z, *w, alpha, alpha_w; PetscInt *segs; PetscInt op[] = {GL_ADD,0}; PetscInt off, len; PetscScalar *x_ptr, *y_ptr; PetscInt *iptr, flag; PetscInt start =0, end, work; PetscInt op2[] = {GL_MIN,0}; PCTFS_gs_ADT PCTFS_gs_handle; PetscInt *nsep, *lnsep, *fo; PetscInt a_n =xyt_handle->mvi->n; PetscInt a_m =xyt_handle->mvi->m; PetscInt *a_local2global=xyt_handle->mvi->local2global; PetscInt level; PetscInt n, m; PetscInt *xcol_sz, *xcol_indices, *stages; PetscScalar **xcol_vals, *x; PetscInt *ycol_sz, *ycol_indices; PetscScalar **ycol_vals, *y; PetscInt n_global; PetscInt xt_nnz =0, xt_max_nnz=0; PetscInt yt_nnz =0, yt_max_nnz=0; PetscInt xt_zero_nnz =0; PetscInt xt_zero_nnz_0=0; PetscInt yt_zero_nnz =0; PetscInt yt_zero_nnz_0=0; PetscBLASInt i1 = 1,dlen; PetscScalar dm1 = -1.0; PetscErrorCode ierr; n =xyt_handle->mvi->n; nsep =xyt_handle->info->nsep; lnsep =xyt_handle->info->lnsep; fo =xyt_handle->info->fo; end =lnsep[0]; level =xyt_handle->level; PCTFS_gs_handle=xyt_handle->mvi->PCTFS_gs_handle; /* is there a null space? */ /* LATER add in ability to detect null space by checking alpha */ for (i=0, j=0; i<=level; i++) j+=nsep[i]; m = j-xyt_handle->ns; if (m!=j) { ierr = PetscPrintf(PETSC_COMM_WORLD,"xyt_generate() :: null space exists %D %D %D\n",m,j,xyt_handle->ns);CHKERRQ(ierr); } ierr = PetscInfo2(0,"xyt_generate() :: X(%D,%D)\n",n,m);CHKERRQ(ierr); /* get and initialize storage for x local */ /* note that x local is nxm and stored by columns */ xcol_sz = (PetscInt*) malloc(m*sizeof(PetscInt)); xcol_indices = (PetscInt*) malloc((2*m+1)*sizeof(PetscInt)); xcol_vals = (PetscScalar**) malloc(m*sizeof(PetscScalar*)); for (i=j=0; i<m; i++, j+=2) { xcol_indices[j]=xcol_indices[j+1]=xcol_sz[i]=-1; xcol_vals[i] = NULL; } xcol_indices[j]=-1; /* get and initialize storage for y local */ /* note that y local is nxm and stored by columns */ ycol_sz = (PetscInt*) malloc(m*sizeof(PetscInt)); ycol_indices = (PetscInt*) malloc((2*m+1)*sizeof(PetscInt)); ycol_vals = (PetscScalar**) malloc(m*sizeof(PetscScalar*)); for (i=j=0; i<m; i++, j+=2) { ycol_indices[j]=ycol_indices[j+1]=ycol_sz[i]=-1; ycol_vals[i] = NULL; } ycol_indices[j]=-1; /* size of separators for each sub-hc working from bottom of tree to top */ /* this looks like nsep[]=segments */ stages = (PetscInt*) malloc((level+1)*sizeof(PetscInt)); segs = (PetscInt*) malloc((level+1)*sizeof(PetscInt)); PCTFS_ivec_zero(stages,level+1); PCTFS_ivec_copy(segs,nsep,level+1); for (i=0; i<level; i++) segs[i+1] += segs[i]; stages[0] = segs[0]; /* temporary vectors */ u = (PetscScalar*) malloc(n*sizeof(PetscScalar)); z = (PetscScalar*) malloc(n*sizeof(PetscScalar)); v = (PetscScalar*) malloc(a_m*sizeof(PetscScalar)); uu = (PetscScalar*) malloc(m*sizeof(PetscScalar)); w = (PetscScalar*) malloc(m*sizeof(PetscScalar)); /* extra nnz due to replication of vertices across separators */ for (i=1, j=0; i<=level; i++) j+=nsep[i]; /* storage for sparse x values */ n_global = xyt_handle->info->n_global; xt_max_nnz = yt_max_nnz = (PetscInt)(2.5*PetscPowReal(1.0*n_global,1.6667) + j*n/2)/PCTFS_num_nodes; x = (PetscScalar*) malloc(xt_max_nnz*sizeof(PetscScalar)); y = (PetscScalar*) malloc(yt_max_nnz*sizeof(PetscScalar)); /* LATER - can embed next sep to fire in gs */ /* time to make the donuts - generate X factor */ for (dim=i=j=0; i<m; i++) { /* time to move to the next level? */ while (i==segs[dim]) { if (dim==level) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"dim about to exceed level\n"); stages[dim++]=i; end +=lnsep[dim]; } stages[dim]=i; /* which column are we firing? */ /* i.e. set v_l */ /* use new seps and do global min across hc to determine which one to fire */ (start<end) ? (col=fo[start]) : (col=INT_MAX); PCTFS_giop_hc(&col,&work,1,op2,dim); /* shouldn't need this */ if (col==INT_MAX) { ierr = PetscInfo(0,"hey ... col==INT_MAX??\n");CHKERRQ(ierr); continue; } /* do I own it? I should */ PCTFS_rvec_zero(v,a_m); if (col==fo[start]) { start++; idx=PCTFS_ivec_linear_search(col, a_local2global, a_n); if (idx!=-1) { v[idx] = 1.0; j++; } else SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"NOT FOUND!\n"); } else { idx=PCTFS_ivec_linear_search(col, a_local2global, a_m); if (idx!=-1) v[idx] = 1.0; } /* perform u = A.v_l */ PCTFS_rvec_zero(u,n); do_matvec(xyt_handle->mvi,v,u); /* uu = X^T.u_l (local portion) */ /* technically only need to zero out first i entries */ /* later turn this into an XYT_solve call ? */ PCTFS_rvec_zero(uu,m); y_ptr=y; iptr = ycol_indices; for (k=0; k<i; k++) { off = *iptr++; len = *iptr++; ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr); PetscStackCall("BLASdot",uu[k] = BLASdot_(&dlen,u+off,&i1,y_ptr,&i1)); y_ptr+=len; } /* uu = X^T.u_l (comm portion) */ PCTFS_ssgl_radd (uu, w, dim, stages); /* z = X.uu */ PCTFS_rvec_zero(z,n); x_ptr=x; iptr = xcol_indices; for (k=0; k<i; k++) { off = *iptr++; len = *iptr++; ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr); PetscStackCall("BLASaxpy",BLASaxpy_(&dlen,&uu[k],x_ptr,&i1,z+off,&i1)); x_ptr+=len; } /* compute v_l = v_l - z */ PCTFS_rvec_zero(v+a_n,a_m-a_n); ierr = PetscBLASIntCast(n,&dlen);CHKERRQ(ierr); PetscStackCall("BLASaxpy",BLASaxpy_(&dlen,&dm1,z,&i1,v,&i1)); /* compute u_l = A.v_l */ if (a_n!=a_m) PCTFS_gs_gop_hc(PCTFS_gs_handle,v,"+\0",dim); PCTFS_rvec_zero(u,n); do_matvec(xyt_handle->mvi,v,u); /* compute sqrt(alpha) = sqrt(u_l^T.u_l) - local portion */ ierr = PetscBLASIntCast(n,&dlen);CHKERRQ(ierr); PetscStackCall("BLASdot",alpha = BLASdot_(&dlen,u,&i1,u,&i1)); /* compute sqrt(alpha) = sqrt(u_l^T.u_l) - comm portion */ PCTFS_grop_hc(&alpha, &alpha_w, 1, op, dim); alpha = (PetscScalar) PetscSqrtReal((PetscReal)alpha); /* check for small alpha */ /* LATER use this to detect and determine null space */ if (fabs(alpha)<1.0e-14) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"bad alpha! %g\n",alpha); /* compute v_l = v_l/sqrt(alpha) */ PCTFS_rvec_scale(v,1.0/alpha,n); PCTFS_rvec_scale(u,1.0/alpha,n); /* add newly generated column, v_l, to X */ flag = 1; off =len=0; for (k=0; k<n; k++) { if (v[k]!=0.0) { len=k; if (flag) {off=k; flag=0;} } } len -= (off-1); if (len>0) { if ((xt_nnz+len)>xt_max_nnz) { ierr = PetscInfo(0,"increasing space for X by 2x!\n");CHKERRQ(ierr); xt_max_nnz *= 2; x_ptr = (PetscScalar*) malloc(xt_max_nnz*sizeof(PetscScalar)); PCTFS_rvec_copy(x_ptr,x,xt_nnz); free(x); x = x_ptr; x_ptr+=xt_nnz; } xt_nnz += len; PCTFS_rvec_copy(x_ptr,v+off,len); /* keep track of number of zeros */ if (dim) { for (k=0; k<len; k++) { if (x_ptr[k]==0.0) xt_zero_nnz++; } } else { for (k=0; k<len; k++) { if (x_ptr[k]==0.0) xt_zero_nnz_0++; } } xcol_indices[2*i] = off; xcol_sz[i] = xcol_indices[2*i+1] = len; xcol_vals[i] = x_ptr; } else { xcol_indices[2*i] = 0; xcol_sz[i] = xcol_indices[2*i+1] = 0; xcol_vals[i] = x_ptr; } /* add newly generated column, u_l, to Y */ flag = 1; off =len=0; for (k=0; k<n; k++) { if (u[k]!=0.0) { len=k; if (flag) { off=k; flag=0; } } } len -= (off-1); if (len>0) { if ((yt_nnz+len)>yt_max_nnz) { ierr = PetscInfo(0,"increasing space for Y by 2x!\n");CHKERRQ(ierr); yt_max_nnz *= 2; y_ptr = (PetscScalar*) malloc(yt_max_nnz*sizeof(PetscScalar)); PCTFS_rvec_copy(y_ptr,y,yt_nnz); free(y); y = y_ptr; y_ptr+=yt_nnz; } yt_nnz += len; PCTFS_rvec_copy(y_ptr,u+off,len); /* keep track of number of zeros */ if (dim) { for (k=0; k<len; k++) { if (y_ptr[k]==0.0) yt_zero_nnz++; } } else { for (k=0; k<len; k++) { if (y_ptr[k]==0.0) yt_zero_nnz_0++; } } ycol_indices[2*i] = off; ycol_sz[i] = ycol_indices[2*i+1] = len; ycol_vals[i] = y_ptr; } else { ycol_indices[2*i] = 0; ycol_sz[i] = ycol_indices[2*i+1] = 0; ycol_vals[i] = y_ptr; } } /* close off stages for execution phase */ while (dim!=level) { stages[dim++]=i; ierr = PetscInfo2(0,"disconnected!!! dim(%D)!=level(%D)\n",dim,level);CHKERRQ(ierr); } stages[dim]=i; xyt_handle->info->n =xyt_handle->mvi->n; xyt_handle->info->m =m; xyt_handle->info->nnz =xt_nnz + yt_nnz; xyt_handle->info->max_nnz =xt_max_nnz + yt_max_nnz; xyt_handle->info->msg_buf_sz =stages[level]-stages[0]; xyt_handle->info->solve_uu = (PetscScalar*) malloc(m*sizeof(PetscScalar)); xyt_handle->info->solve_w = (PetscScalar*) malloc(m*sizeof(PetscScalar)); xyt_handle->info->x =x; xyt_handle->info->xcol_vals =xcol_vals; xyt_handle->info->xcol_sz =xcol_sz; xyt_handle->info->xcol_indices=xcol_indices; xyt_handle->info->stages =stages; xyt_handle->info->y =y; xyt_handle->info->ycol_vals =ycol_vals; xyt_handle->info->ycol_sz =ycol_sz; xyt_handle->info->ycol_indices=ycol_indices; free(segs); free(u); free(v); free(uu); free(z); free(w); return(0); }
static PetscErrorCode estsv(PetscInt n, PetscReal *r, PetscInt ldr, PetscReal *svmin, PetscReal *z) { PetscBLASInt blas1=1, blasn=n, blasnmi, blasj, blasldr = ldr; PetscInt i,j; PetscReal e,temp,w,wm,ynorm,znorm,s,sm; PetscFunctionBegin; for (i=0;i<n;i++) { z[i]=0.0; } e = PetscAbs(r[0]); if (e == 0.0) { *svmin = 0.0; z[0] = 1.0; } else { /* Solve R'*y = e */ for (i=0;i<n;i++) { /* Scale y. The scaling factor (0.01) reduces the number of scalings */ if (z[i] >= 0.0) e =-PetscAbs(e); else e = PetscAbs(e); if (PetscAbs(e - z[i]) > PetscAbs(r[i + ldr*i])) { temp = PetscMin(0.01,PetscAbs(r[i + ldr*i]))/PetscAbs(e-z[i]); PetscStackCallBLAS("BLASscal",BLASscal_(&blasn, &temp, z, &blas1)); e = temp*e; } /* Determine the two possible choices of y[i] */ if (r[i + ldr*i] == 0.0) { w = wm = 1.0; } else { w = (e - z[i]) / r[i + ldr*i]; wm = - (e + z[i]) / r[i + ldr*i]; } /* Chose y[i] based on the predicted value of y[j] for j>i */ s = PetscAbs(e - z[i]); sm = PetscAbs(e + z[i]); for (j=i+1;j<n;j++) { sm += PetscAbs(z[j] + wm * r[i + ldr*j]); } if (i < n-1) { blasnmi = n-i-1; PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&blasnmi, &w, &r[i + ldr*(i+1)], &blasldr, &z[i+1], &blas1)); s += BLASasum_(&blasnmi, &z[i+1], &blas1); } if (s < sm) { temp = wm - w; w = wm; if (i < n-1) { PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&blasnmi, &temp, &r[i + ldr*(i+1)], &blasldr, &z[i+1], &blas1)); } } z[i] = w; } ynorm = BLASnrm2_(&blasn, z, &blas1); /* Solve R*z = y */ for (j=n-1; j>=0; j--) { /* Scale z */ if (PetscAbs(z[j]) > PetscAbs(r[j + ldr*j])) { temp = PetscMin(0.01, PetscAbs(r[j + ldr*j] / z[j])); PetscStackCallBLAS("BLASscal",BLASscal_(&blasn, &temp, z, &blas1)); ynorm *=temp; } if (r[j + ldr*j] == 0) { z[j] = 1.0; } else { z[j] = z[j] / r[j + ldr*j]; } temp = -z[j]; blasj=j; PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&blasj,&temp,&r[0+ldr*j],&blas1,z,&blas1)); } /* Compute svmin and normalize z */ znorm = 1.0 / BLASnrm2_(&blasn, z, &blas1); *svmin = ynorm*znorm; PetscStackCallBLAS("BLASscal",BLASscal_(&blasn, &znorm, z, &blas1)); } PetscFunctionReturn(0); }
/* c *********** c c Subroutine dgqt c c Given an n by n symmetric matrix A, an n-vector b, and a c positive number delta, this subroutine determines a vector c x which approximately minimizes the quadratic function c c f(x) = (1/2)*x'*A*x + b'*x c c subject to the Euclidean norm constraint c c norm(x) <= delta. c c This subroutine computes an approximation x and a Lagrange c multiplier par such that either par is zero and c c norm(x) <= (1+rtol)*delta, c c or par is positive and c c abs(norm(x) - delta) <= rtol*delta. c c If xsol is the solution to the problem, the approximation x c satisfies c c f(x) <= ((1 - rtol)**2)*f(xsol) c c The subroutine statement is c c subroutine dgqt(n,a,lda,b,delta,rtol,atol,itmax, c par,f,x,info,z,wa1,wa2) c c where c c n is an integer variable. c On entry n is the order of A. c On exit n is unchanged. c c a is a double precision array of dimension (lda,n). c On entry the full upper triangle of a must contain the c full upper triangle of the symmetric matrix A. c On exit the array contains the matrix A. c c lda is an integer variable. c On entry lda is the leading dimension of the array a. c On exit lda is unchanged. c c b is an double precision array of dimension n. c On entry b specifies the linear term in the quadratic. c On exit b is unchanged. c c delta is a double precision variable. c On entry delta is a bound on the Euclidean norm of x. c On exit delta is unchanged. c c rtol is a double precision variable. c On entry rtol is the relative accuracy desired in the c solution. Convergence occurs if c c f(x) <= ((1 - rtol)**2)*f(xsol) c c On exit rtol is unchanged. c c atol is a double precision variable. c On entry atol is the absolute accuracy desired in the c solution. Convergence occurs when c c norm(x) <= (1 + rtol)*delta c c max(-f(x),-f(xsol)) <= atol c c On exit atol is unchanged. c c itmax is an integer variable. c On entry itmax specifies the maximum number of iterations. c On exit itmax is unchanged. c c par is a double precision variable. c On entry par is an initial estimate of the Lagrange c multiplier for the constraint norm(x) <= delta. c On exit par contains the final estimate of the multiplier. c c f is a double precision variable. c On entry f need not be specified. c On exit f is set to f(x) at the output x. c c x is a double precision array of dimension n. c On entry x need not be specified. c On exit x is set to the final estimate of the solution. c c info is an integer variable. c On entry info need not be specified. c On exit info is set as follows: c c info = 1 The function value f(x) has the relative c accuracy specified by rtol. c c info = 2 The function value f(x) has the absolute c accuracy specified by atol. c c info = 3 Rounding errors prevent further progress. c On exit x is the best available approximation. c c info = 4 Failure to converge after itmax iterations. c On exit x is the best available approximation. c c z is a double precision work array of dimension n. c c wa1 is a double precision work array of dimension n. c c wa2 is a double precision work array of dimension n. c c Subprograms called c c MINPACK-2 ...... destsv c c LAPACK ......... dpotrf c c Level 1 BLAS ... daxpy, dcopy, ddot, dnrm2, dscal c c Level 2 BLAS ... dtrmv, dtrsv c c MINPACK-2 Project. October 1993. c Argonne National Laboratory and University of Minnesota. c Brett M. Averick, Richard Carter, and Jorge J. More' c c *********** */ PetscErrorCode gqt(PetscInt n, PetscReal *a, PetscInt lda, PetscReal *b, PetscReal delta, PetscReal rtol, PetscReal atol, PetscInt itmax, PetscReal *retpar, PetscReal *retf, PetscReal *x, PetscInt *retinfo, PetscInt *retits, PetscReal *z, PetscReal *wa1, PetscReal *wa2) { PetscErrorCode ierr; PetscReal f=0.0,p001=0.001,p5=0.5,minusone=-1,delta2=delta*delta; PetscInt iter, j, rednc,info; PetscBLASInt indef; PetscBLASInt blas1=1, blasn=n, iblas, blaslda = lda,blasldap1=lda+1,blasinfo; PetscReal alpha, anorm, bnorm, parc, parf, parl, pars, par=*retpar,paru, prod, rxnorm, rznorm=0.0, temp, xnorm; PetscFunctionBegin; parf = 0.0; xnorm = 0.0; rxnorm = 0.0; rednc = 0; for (j=0; j<n; j++) { x[j] = 0.0; z[j] = 0.0; } /* Copy the diagonal and save A in its lower triangle */ PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn,a,&blasldap1, wa1, &blas1)); for (j=0;j<n-1;j++) { iblas = n - j - 1; PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[j + lda*(j+1)], &blaslda, &a[j+1 + lda*j], &blas1)); } /* Calculate the l1-norm of A, the Gershgorin row sums, and the l2-norm of b */ anorm = 0.0; for (j=0;j<n;j++) { wa2[j] = BLASasum_(&blasn, &a[0 + lda*j], &blas1); CHKMEMQ; anorm = PetscMax(anorm,wa2[j]); } for (j=0;j<n;j++) { wa2[j] = wa2[j] - PetscAbs(wa1[j]); } bnorm = BLASnrm2_(&blasn,b,&blas1); CHKMEMQ; /* Calculate a lower bound, pars, for the domain of the problem. Also calculate an upper bound, paru, and a lower bound, parl, for the Lagrange multiplier. */ pars = parl = paru = -anorm; for (j=0;j<n;j++) { pars = PetscMax(pars, -wa1[j]); parl = PetscMax(parl, wa1[j] + wa2[j]); paru = PetscMax(paru, -wa1[j] + wa2[j]); } parl = PetscMax(bnorm/delta - parl,pars); parl = PetscMax(0.0,parl); paru = PetscMax(0.0, bnorm/delta + paru); /* If the input par lies outside of the interval (parl, paru), set par to the closer endpoint. */ par = PetscMax(par,parl); par = PetscMin(par,paru); /* Special case: parl == paru */ paru = PetscMax(paru, (1.0 + rtol)*parl); /* Beginning of an iteration */ info = 0; for (iter=1;iter<=itmax;iter++) { /* Safeguard par */ if (par <= pars && paru > 0) { par = PetscMax(p001, PetscSqrtScalar(parl/paru)) * paru; } /* Copy the lower triangle of A into its upper triangle and compute A + par*I */ for (j=0;j<n-1;j++) { iblas = n - j - 1; PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[j+1 + j*lda], &blas1,&a[j + (j+1)*lda], &blaslda)); } for (j=0;j<n;j++) { a[j + j*lda] = wa1[j] + par; } /* Attempt the Cholesky factorization of A without referencing the lower triangular part. */ PetscStackCallBLAS("LAPACKpotrf",LAPACKpotrf_("U",&blasn,a,&blaslda,&indef)); /* Case 1: A + par*I is pos. def. */ if (indef == 0) { /* Compute an approximate solution x and save the last value of par with A + par*I pos. def. */ parf = par; PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn, b, &blas1, wa2, &blas1)); PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","T","N",&blasn,&blas1,a,&blaslda,wa2,&blasn,&blasinfo)); rxnorm = BLASnrm2_(&blasn, wa2, &blas1); PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","N","N",&blasn,&blas1,a,&blaslda,wa2,&blasn,&blasinfo)); PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn, wa2, &blas1, x, &blas1)); PetscStackCallBLAS("BLASscal",BLASscal_(&blasn, &minusone, x, &blas1)); xnorm = BLASnrm2_(&blasn, x, &blas1); CHKMEMQ; /* Test for convergence */ if (PetscAbs(xnorm - delta) <= rtol*delta || (par == 0 && xnorm <= (1.0+rtol)*delta)) { info = 1; } /* Compute a direction of negative curvature and use this information to improve pars. */ iblas=blasn*blasn; ierr = estsv(n,a,lda,&rznorm,z);CHKERRQ(ierr); CHKMEMQ; pars = PetscMax(pars, par-rznorm*rznorm); /* Compute a negative curvature solution of the form x + alpha*z, where norm(x+alpha*z)==delta */ rednc = 0; if (xnorm < delta) { /* Compute alpha */ prod = BLASdot_(&blasn, z, &blas1, x, &blas1) / delta; temp = (delta - xnorm)*((delta + xnorm)/delta); alpha = temp/(PetscAbs(prod) + PetscSqrtScalar(prod*prod + temp/delta)); if (prod >= 0) alpha = PetscAbs(alpha); else alpha =-PetscAbs(alpha); /* Test to decide if the negative curvature step produces a larger reduction than with z=0 */ rznorm = PetscAbs(alpha) * rznorm; if ((rznorm*rznorm + par*xnorm*xnorm)/(delta2) <= par) { rednc = 1; } /* Test for convergence */ if (p5 * rznorm*rznorm / delta2 <= rtol*(1.0-p5*rtol)*(par + rxnorm*rxnorm/delta2)) { info = 1; } else if (info == 0 && (p5*(par + rxnorm*rxnorm/delta2) <= atol/delta2)) { info = 2; } } /* Compute the Newton correction parc to par. */ if (xnorm == 0) { parc = -par; } else { PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn, x, &blas1, wa2, &blas1)); temp = 1.0/xnorm; PetscStackCallBLAS("BLASscal",BLASscal_(&blasn, &temp, wa2, &blas1)); PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","T","N",&blasn, &blas1, a, &blaslda, wa2, &blasn, &blasinfo)); temp = BLASnrm2_(&blasn, wa2, &blas1); parc = (xnorm - delta)/(delta*temp*temp); } /* update parl or paru */ if (xnorm > delta) { parl = PetscMax(parl, par); } else if (xnorm < delta) { paru = PetscMin(paru, par); } } else { /* Case 2: A + par*I is not pos. def. */ /* Use the rank information from the Cholesky decomposition to update par. */ if (indef > 1) { /* Restore column indef to A + par*I. */ iblas = indef - 1; PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[indef-1 + 0*lda],&blaslda,&a[0 + (indef-1)*lda],&blas1)); a[indef-1 + (indef-1)*lda] = wa1[indef-1] + par; /* compute parc. */ PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[0 + (indef-1)*lda], &blas1, wa2, &blas1)); PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","T","N",&iblas,&blas1,a,&blaslda,wa2,&blasn,&blasinfo)); PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,wa2,&blas1,&a[0 + (indef-1)*lda],&blas1)); temp = BLASnrm2_(&iblas,&a[0 + (indef-1)*lda],&blas1); CHKMEMQ; a[indef-1 + (indef-1)*lda] -= temp*temp; PetscStackCallBLAS("LAPACKtrtr",LAPACKtrtrs_("U","N","N",&iblas,&blas1,a,&blaslda,wa2,&blasn,&blasinfo)); } wa2[indef-1] = -1.0; iblas = indef; temp = BLASnrm2_(&iblas,wa2,&blas1); parc = - a[indef-1 + (indef-1)*lda]/(temp*temp); pars = PetscMax(pars,par+parc); /* If necessary, increase paru slightly. This is needed because in some exceptional situations paru is the optimal value of par. */ paru = PetscMax(paru, (1.0+rtol)*pars); } /* Use pars to update parl */ parl = PetscMax(parl,pars); /* Test for converged. */ if (info == 0) { if (iter == itmax) info=4; if (paru <= (1.0+p5*rtol)*pars) info=3; if (paru == 0.0) info = 2; } /* If exiting, store the best approximation and restore the upper triangle of A. */ if (info != 0) { /* Compute the best current estimates for x and f. */ par = parf; f = -p5 * (rxnorm*rxnorm + par*xnorm*xnorm); if (rednc) { f = -p5 * (rxnorm*rxnorm + par*delta*delta - rznorm*rznorm); PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&blasn, &alpha, z, &blas1, x, &blas1)); } /* Restore the upper triangle of A */ for (j = 0; j<n; j++) { iblas = n - j - 1; PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[j+1 + j*lda],&blas1, &a[j + (j+1)*lda],&blaslda)); } iblas = lda+1; PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn,wa1,&blas1,a,&iblas)); break; } par = PetscMax(parl,par+parc); } *retpar = par; *retf = f; *retinfo = info; *retits = iter; CHKMEMQ; PetscFunctionReturn(0); }
PetscErrorCode KSPAGMRESRodvec(KSP ksp, PetscInt nvec, PetscScalar *In, Vec Out) { KSP_AGMRES *agmres = (KSP_AGMRES*) ksp->data; MPI_Comm comm; PetscScalar *Qloc = agmres->Qloc; PetscScalar *sgn = agmres->sgn; PetscScalar *tloc = agmres->tloc; PetscMPIInt rank = agmres->rank; PetscMPIInt First = agmres->First, Last = agmres->Last; PetscMPIInt Iright = agmres->Iright, Ileft = agmres->Ileft; PetscScalar *y, *zloc; PetscErrorCode ierr; PetscInt nloc,tag,d, len, i, j; PetscInt dpt,pas; PetscReal c, s, rho, zp, zq, yd, tt; MPI_Status status; PetscFunctionBegin; ierr = PetscObjectGetComm((PetscObject)ksp,&comm);CHKERRQ(ierr); tag = 0x666; pas = 1; ierr = VecGetLocalSize(VEC_V(0), &nloc);CHKERRQ(ierr); ierr = PetscMalloc1(nvec, &y);CHKERRQ(ierr); ierr = PetscMemcpy(y, In, nvec*sizeof(PetscScalar));CHKERRQ(ierr); ierr = VecGetArray(Out, &zloc);CHKERRQ(ierr); if (rank == Last) { for (i = 0; i < nvec; i++) y[i] = sgn[i] * y[i]; } for (i = 0; i < nloc; i++) zloc[i] = 0.0; if (agmres->size == 1) PetscStackCallBLAS("BLAScopy",BLAScopy_(&nvec, y, &pas, &(zloc[0]), &pas)); else { for (d = nvec - 1; d >= 0; d--) { if (rank == First) { ierr = MPI_Recv(&(zloc[d]), 1, MPIU_SCALAR, Iright, tag, comm, &status);CHKERRQ(ierr); } else { for (j = nvec - 1; j >= d + 1; j--) { i = j - d; ierr = KSPAGMRESRoddecGivens(&c, &s, &(Qloc[j * nloc + i]), 0); zp = zloc[i-1]; zq = zloc[i]; zloc[i-1] = c * zp + s * zq; zloc[i] = -s * zp + c * zq; } ierr = KSPAGMRESRoddecGivens(&c, &s, &(Qloc[d * nloc]), 0); if (rank == Last) { zp = y[d]; zq = zloc[0]; y[d] = c * zp + s * zq; zloc[0] = -s * zp + c * zq; ierr = MPI_Send(&(y[d]), 1, MPIU_SCALAR, Ileft, tag, comm);CHKERRQ(ierr); } else { ierr = MPI_Recv(&yd, 1, MPIU_SCALAR, Iright, tag, comm, &status);CHKERRQ(ierr); zp = yd; zq = zloc[0]; yd = c * zp + s * zq; zloc[0] = -s * zp + c * zq; ierr = MPI_Send(&yd, 1, MPIU_SCALAR, Ileft, tag, comm);CHKERRQ(ierr); } } } } for (j = nvec - 1; j >= 0; j--) { dpt = j * nloc + j; if (tloc[j] != 0.0) { len = nloc - j; rho = Qloc[dpt]; Qloc[dpt] = 1.0; tt = tloc[j] * (BLASdot_(&len, &(Qloc[dpt]), &pas, &(zloc[j]), &pas)); PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&len, &tt, &(Qloc[dpt]), &pas, &(zloc[j]), &pas)); Qloc[dpt] = rho; } } ierr = VecRestoreArray(Out, &zloc);CHKERRQ(ierr); ierr = PetscFree(y);CHKERRQ(ierr); PetscFunctionReturn(0); }
PetscErrorCode KSPAGMRESRoddec(KSP ksp, PetscInt nvec) { KSP_AGMRES *agmres = (KSP_AGMRES*) ksp->data; MPI_Comm comm; PetscScalar *Qloc = agmres->Qloc; PetscScalar *sgn = agmres->sgn; PetscScalar *tloc = agmres->tloc; PetscErrorCode ierr; PetscReal *wbufptr = agmres->wbufptr; PetscMPIInt rank = agmres->rank; PetscMPIInt First = agmres->First; PetscMPIInt Last = agmres->Last; PetscBLASInt nloc,pas,len; PetscInt d, i, j, k; PetscInt pos,tag; PetscReal c, s, rho, Ajj, val, tt, old; PetscScalar *col; MPI_Status status; PetscBLASInt N = MAXKSPSIZE + 1; PetscFunctionBegin; ierr = PetscObjectGetComm((PetscObject)ksp,&comm);CHKERRQ(ierr); tag = 0x666; ierr = PetscLogEventBegin(KSP_AGMRESRoddec,ksp,0,0,0);CHKERRQ(ierr); ierr = PetscMemzero(agmres->Rloc, N*N*sizeof(PetscScalar));CHKERRQ(ierr); /* check input arguments */ if (nvec < 1) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_OUTOFRANGE, "The number of input vectors shoud be positive"); ierr = VecGetLocalSize(VEC_V(0), &nloc);CHKERRQ(ierr); if (nvec > nloc) SETERRQ(PetscObjectComm((PetscObject)ksp), PETSC_ERR_ARG_WRONG, "In QR factorization, the number of local rows should be greater or equal to the number of columns"); pas = 1; k = 0; /* Copy the vectors of the basis */ for (j = 0; j < nvec; j++) { ierr = VecGetArray(VEC_V(j), &col);CHKERRQ(ierr); PetscStackCallBLAS("BLAScopy",BLAScopy_(&nloc, col, &pas, &Qloc[j*nloc], &pas)); ierr = VecRestoreArray(VEC_V(j), &col);CHKERRQ(ierr); } /* Each process performs a local QR on its own block */ for (j = 0; j < nvec; j++) { len = nloc - j; Ajj = Qloc[j*nloc+j]; rho = -PetscSign(Ajj) * BLASnrm2_(&len, &(Qloc[j*nloc+j]), &pas); if (rho == 0.0) tloc[j] = 0.0; else { tloc[j] = (Ajj - rho) / rho; len = len - 1; val = 1.0 / (Ajj - rho); PetscStackCallBLAS("BLASscal",BLASscal_(&len, &val, &(Qloc[j*nloc+j+1]), &pas)); Qloc[j*nloc+j] = 1.0; len = len + 1; for (k = j + 1; k < nvec; k++) { PetscStackCallBLAS("BLASdot",tt = tloc[j] * BLASdot_(&len, &(Qloc[j*nloc+j]), &pas, &(Qloc[k*nloc+j]), &pas)); PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&len, &tt, &(Qloc[j*nloc+j]), &pas, &(Qloc[k*nloc+j]), &pas)); } Qloc[j*nloc+j] = rho; } } /*annihilate undesirable Rloc, diagonal by diagonal*/ for (d = 0; d < nvec; d++) { len = nvec - d; if (rank == First) { PetscStackCallBLAS("BLAScopy",BLAScopy_(&len, &(Qloc[d*nloc+d]), &nloc, &(wbufptr[d]), &pas)); ierr = MPI_Send(&(wbufptr[d]), len, MPIU_SCALAR, rank + 1, tag, comm);CHKERRQ(ierr); } else { ierr = MPI_Recv(&(wbufptr[d]), len, MPIU_SCALAR, rank - 1, tag, comm, &status);CHKERRQ(ierr); /*Elimination of Rloc(1,d)*/ c = wbufptr[d]; s = Qloc[d*nloc]; ierr = KSPAGMRESRoddecGivens(&c, &s, &rho, 1); /*Apply Givens Rotation*/ for (k = d; k < nvec; k++) { old = wbufptr[k]; wbufptr[k] = c * old - s * Qloc[k*nloc]; Qloc[k*nloc] = s * old + c * Qloc[k*nloc]; } Qloc[d*nloc] = rho; if (rank != Last) { ierr = MPI_Send(& (wbufptr[d]), len, MPIU_SCALAR, rank + 1, tag, comm);CHKERRQ(ierr); } /* zero-out the d-th diagonal of Rloc ...*/ for (j = d + 1; j < nvec; j++) { /* elimination of Rloc[i][j]*/ i = j - d; c = Qloc[j*nloc+i-1]; s = Qloc[j*nloc+i]; ierr = KSPAGMRESRoddecGivens(&c, &s, &rho, 1);CHKERRQ(ierr); for (k = j; k < nvec; k++) { old = Qloc[k*nloc+i-1]; Qloc[k*nloc+i-1] = c * old - s * Qloc[k*nloc+i]; Qloc[k*nloc+i] = s * old + c * Qloc[k*nloc+i]; } Qloc[j*nloc+i] = rho; } if (rank == Last) { PetscStackCallBLAS("BLAScopy",BLAScopy_(&len, &(wbufptr[d]), &pas, RLOC(d,d), &N)); for (k = d + 1; k < nvec; k++) *RLOC(k,d) = 0.0; } } } if (rank == Last) { for (d = 0; d < nvec; d++) { pos = nvec - d; sgn[d] = PetscSign(*RLOC(d,d)); PetscStackCallBLAS("BLASscal",BLASscal_(&pos, &(sgn[d]), RLOC(d,d), &N)); } } /*BroadCast Rloc to all other processes * NWD : should not be needed */ ierr = MPI_Bcast(agmres->Rloc,N*N,MPIU_SCALAR,Last,comm);CHKERRQ(ierr); ierr = PetscLogEventEnd(KSP_AGMRESRoddec,ksp,0,0,0);CHKERRQ(ierr); PetscFunctionReturn(0); }
static PetscErrorCode gs_gop_vec_pairwise_plus( gs_id *gs, PetscScalar *in_vals, PetscInt step) { PetscScalar *dptr1, *dptr2, *dptr3, *in1, *in2; PetscInt *iptr, *msg_list, *msg_size, **msg_nodes; PetscInt *pw, *list, *size, **nodes; MPI_Request *msg_ids_in, *msg_ids_out, *ids_in, *ids_out; MPI_Status status; PetscBLASInt i1 = 1,dstep; PetscErrorCode ierr; PetscFunctionBegin; /* strip and load s */ msg_list =list = gs->pair_list; msg_size =size = gs->msg_sizes; msg_nodes=nodes = gs->node_list; iptr=pw = gs->pw_elm_list; dptr1=dptr3 = gs->pw_vals; msg_ids_in = ids_in = gs->msg_ids_in; msg_ids_out = ids_out = gs->msg_ids_out; dptr2 = gs->out; in1=in2 = gs->in; /* post the receives */ /* msg_nodes=nodes; */ do { /* Should MPI_ANY_SOURCE be replaced by *list ? In that case do the second one *list and do list++ afterwards */ ierr = MPI_Irecv(in1, *size *step, MPIU_SCALAR, MPI_ANY_SOURCE, MSGTAG1 + *list, gs->gs_comm, msg_ids_in);CHKERRQ(ierr); list++;msg_ids_in++; in1 += *size++ *step; } while (*++msg_nodes); msg_nodes=nodes; /* load gs values into in out gs buffers */ while (*iptr >= 0) { rvec_copy(dptr3,in_vals + *iptr*step,step); dptr3+=step; iptr++; } /* load out buffers and post the sends */ while ((iptr = *msg_nodes++)) { dptr3 = dptr2; while (*iptr >= 0) { rvec_copy(dptr2,dptr1 + *iptr*step,step); dptr2+=step; iptr++; } ierr = MPI_Isend(dptr3, *msg_size *step, MPIU_SCALAR, *msg_list, MSGTAG1+my_id, gs->gs_comm, msg_ids_out);CHKERRQ(ierr); msg_size++; msg_list++;msg_ids_out++; } /* tree */ if (gs->max_left_over) {gs_gop_vec_tree_plus(gs,in_vals,step);} /* process the received data */ msg_nodes=nodes; while ((iptr = *nodes++)){ PetscScalar d1 = 1.0; /* Should I check the return value of MPI_Wait() or status? */ /* Can this loop be replaced by a call to MPI_Waitall()? */ ierr = MPI_Wait(ids_in, &status);CHKERRQ(ierr); ids_in++; while (*iptr >= 0) { dstep = PetscBLASIntCast(step); BLASaxpy_(&dstep,&d1,in2,&i1,dptr1 + *iptr*step,&i1); in2+=step; iptr++; } } /* replace vals */ while (*pw >= 0) { rvec_copy(in_vals + *pw*step,dptr1,step); dptr1+=step; pw++; } /* clear isend message handles */ /* This changed for clarity though it could be the same */ while (*msg_nodes++) /* Should I check the return value of MPI_Wait() or status? */ /* Can this loop be replaced by a call to MPI_Waitall()? */ {ierr = MPI_Wait(ids_out, &status);CHKERRQ(ierr);ids_out++;} PetscFunctionReturn(0); }