Actual source code: slepcutil.c

  1: /*
  2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
  4:    Copyright (c) 2002-2010, Universidad Politecnica de Valencia, Spain

  6:    This file is part of SLEPc.
  7:       
  8:    SLEPc is free software: you can redistribute it and/or modify it under  the
  9:    terms of version 3 of the GNU Lesser General Public License as published by
 10:    the Free Software Foundation.

 12:    SLEPc  is  distributed in the hope that it will be useful, but WITHOUT  ANY 
 13:    WARRANTY;  without even the implied warranty of MERCHANTABILITY or  FITNESS 
 14:    FOR  A  PARTICULAR PURPOSE. See the GNU Lesser General Public  License  for 
 15:    more details.

 17:    You  should have received a copy of the GNU Lesser General  Public  License
 18:    along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
 19:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 20: */

 22:  #include slepcsys.h
 23: #include "petscblaslapack.h"
 24: #include <stdlib.h>

 26: PetscLogEvent SLEPC_UpdateVectors = 0, SLEPC_VecMAXPBY = 0;

 30: /*@
 31:    SlepcVecSetRandom - Sets all components of a vector to random numbers.

 33:    Collective on Vec

 35:    Input/Output Parameter:
 36: .  x  - the vector

 38:    Input Parameter:
 39: -  rctx - the random number context, formed by PetscRandomCreate(), or PETSC_NULL and
 40:           it will create one internally.

 42:    Note:
 43:    This operation is equivalent to VecSetRandom - the difference is that the
 44:    vector generated by SlepcVecSetRandom is the same irrespective of the size
 45:    of the communicator.

 47:    Level: developer
 48: @*/
 49: PetscErrorCode SlepcVecSetRandom(Vec x,PetscRandom rctx)
 50: {
 52:   PetscRandom    randObj = PETSC_NULL;
 53:   PetscInt       i,n,low,high;
 54:   PetscScalar    *px,t;
 55: 
 59:   if (!rctx) {
 60:     MPI_Comm comm;
 61:     PetscObjectGetComm((PetscObject)x,&comm);
 62:     PetscRandomCreate(comm,&randObj);
 63:     PetscRandomSetFromOptions(randObj);
 64:     rctx = randObj;
 65:   }

 67:   VecGetSize(x,&n);
 68:   VecGetOwnershipRange(x,&low,&high);
 69:   VecGetArray(x,&px);
 70:   for (i=0;i<n;i++) {
 71:     PetscRandomGetValue(rctx,&t);
 72:     if (i>=low && i<high) px[i-low] = t;
 73:   }
 74:   VecRestoreArray(x,&px);
 75:   if (randObj) {
 76:     PetscRandomDestroy(randObj);
 77:   }
 78:   PetscObjectStateIncrease((PetscObject)x);
 79:   return(0);
 80: }

 84: /*@
 85:    SlepcIsHermitian - Checks if a matrix is Hermitian or not.

 87:    Collective on Mat

 89:    Input parameter:
 90: .  A  - the matrix

 92:    Output parameter:
 93: .  is  - flag indicating if the matrix is Hermitian

 95:    Notes: 
 96:    The result of Ax and A^Hx (with a random x) is compared, but they 
 97:    could be equal also for some non-Hermitian matrices.

 99:    This routine will not work with matrix formats MATSEQSBAIJ or MATMPISBAIJ,
100:    or when PETSc is configured with complex scalars.
101:    
102:    Level: developer

104: @*/
105: PetscErrorCode SlepcIsHermitian(Mat A,PetscTruth *is)
106: {
108:   PetscInt       M,N,m,n;
109:   Vec            x,w1,w2;
110:   MPI_Comm       comm;
111:   PetscReal      norm;
112:   PetscTruth     has;


116: #if !defined(PETSC_USE_COMPLEX)
117:   PetscTypeCompare((PetscObject)A,MATSEQSBAIJ,is);
118:   if (*is) return(0);
119:   PetscTypeCompare((PetscObject)A,MATMPISBAIJ,is);
120:   if (*is) return(0);
121: #endif

123:   *is = PETSC_FALSE;
124:   MatGetSize(A,&M,&N);
125:   MatGetLocalSize(A,&m,&n);
126:   if (M!=N) return(0);
127:   MatHasOperation(A,MATOP_MULT,&has);
128:   if (!has) return(0);
129:   MatHasOperation(A,MATOP_MULT_TRANSPOSE,&has);
130:   if (!has) return(0);

132:   PetscObjectGetComm((PetscObject)A,&comm);
133:   VecCreate(comm,&x);
134:   VecSetSizes(x,n,N);
135:   VecSetFromOptions(x);
136:   SlepcVecSetRandom(x,PETSC_NULL);
137:   VecDuplicate(x,&w1);
138:   VecDuplicate(x,&w2);
139:   MatMult(A,x,w1);
140:   MatMultTranspose(A,x,w2);
141:   VecConjugate(w2);
142:   VecAXPY(w2,-1.0,w1);
143:   VecNorm(w2,NORM_2,&norm);
144:   if (norm<1.0e-6) *is = PETSC_TRUE;
145:   VecDestroy(x);
146:   VecDestroy(w1);
147:   VecDestroy(w2);

149:   return(0);
150: }

152: #if !defined(PETSC_USE_COMPLEX)

156: /*@C
157:    SlepcAbsEigenvalue - Returns the absolute value of a complex number given
158:    its real and imaginary parts.

160:    Not collective

162:    Input parameters:
163: +  x  - the real part of the complex number
164: -  y  - the imaginary part of the complex number

166:    Notes: 
167:    This function computes sqrt(x**2+y**2), taking care not to cause unnecessary
168:    overflow. It is based on LAPACK's DLAPY2.

170:    Level: developer

172: @*/
173: PetscReal SlepcAbsEigenvalue(PetscScalar x,PetscScalar y)
174: {
175:   PetscReal xabs,yabs,w,z,t;
177:   xabs = PetscAbsReal(x);
178:   yabs = PetscAbsReal(y);
179:   w = PetscMax(xabs,yabs);
180:   z = PetscMin(xabs,yabs);
181:   if (z == 0.0) PetscFunctionReturn(w);
182:   t = z/w;
183:   PetscFunctionReturn(w*sqrt(1.0+t*t));
184: }

186: #endif

190: /*@C
191:    SlepcVecNormalize - Normalizes a possibly complex vector by the 2-norm.

193:    Not collective

195:    Input parameters:
196: +  xr         - the real part of the vector (overwritten on output)
197: +  xi         - the imaginary part of the vector (not referenced if iscomplex is false)
198: -  iscomplex - a flag that indicating if the vector is complex

200:    Output parameter:
201: .  norm      - the vector norm before normalization (can be set to PETSC_NULL)

203:    Level: developer

205: @*/
206: PetscErrorCode SlepcVecNormalize(Vec xr,Vec xi,PetscTruth iscomplex,PetscReal *norm)
207: {
209: #if !defined(PETSC_USE_COMPLEX)
210:   PetscReal      normr,normi,alpha;
211: #endif

214: #if !defined(PETSC_USE_COMPLEX)
215:   if (iscomplex) {
216:     VecNorm(xr,NORM_2,&normr);
217:     VecNorm(xi,NORM_2,&normi);
218:     alpha = SlepcAbsEigenvalue(normr,normi);
219:     if (norm) *norm = alpha;
220:     alpha = 1.0 / alpha;
221:     VecScale(xr,alpha);
222:     VecScale(xi,alpha);
223:   } else
224: #endif
225:   {
226:     VecNormalize(xr,norm);
227:   }
228:   return(0);
229: }

233: /*@C
234:    SlepcMatConvertSeqDense - Converts a parallel matrix to another one in sequential 
235:    dense format replicating the values in every processor.

237:    Collective

239:    Input parameters:
240: +  A  - the source matrix
241: -  B  - the target matrix

243:    Level: developer
244:    
245: @*/
246: PetscErrorCode SlepcMatConvertSeqDense(Mat mat,Mat *newmat)
247: {
249:   PetscInt       m,n;
250:   PetscMPIInt    size;
251:   MPI_Comm       comm;
252:   Mat            *M;
253:   IS             isrow, iscol;
254:   PetscTruth     flg;


260:   PetscObjectGetComm((PetscObject)mat,&comm);
261:   MPI_Comm_size(comm,&size);

263:   if (size > 1) {
264:     /* assemble full matrix on every processor */
265:     MatGetSize(mat,&m,&n);
266:     ISCreateStride(PETSC_COMM_SELF,m,0,1,&isrow);
267:     ISCreateStride(PETSC_COMM_SELF,n,0,1,&iscol);
268:     MatGetSubMatrices(mat,1,&isrow,&iscol,MAT_INITIAL_MATRIX,&M);
269:     ISDestroy(isrow);
270:     ISDestroy(iscol);

272:     /* Fake support for "inplace" convert */
273:     if (*newmat == mat) {
274:       MatDestroy(mat);
275:     }
276:     *newmat = *M;
277:     PetscFree(M);
278: 
279:     /* convert matrix to MatSeqDense */
280:     PetscTypeCompare((PetscObject)*newmat,MATSEQDENSE,&flg);
281:     if (!flg) {
282:       MatConvert(*newmat,MATSEQDENSE,MAT_INITIAL_MATRIX,newmat);
283:     }
284:   } else {
285:     /* convert matrix to MatSeqDense */
286:     MatConvert(mat,MATSEQDENSE,MAT_INITIAL_MATRIX,newmat);
287:   }

289:   return(0);
290: }

294: /*@
295:    SlepcCheckOrthogonality - Checks (or prints) the level of orthogonality
296:    of a set of vectors.

298:    Collective on Vec

300:    Input parameters:
301: +  V  - a set of vectors
302: .  nv - number of V vectors
303: .  W  - an alternative set of vectors (optional)
304: .  nw - number of W vectors
305: -  B  - matrix defining the inner product (optional)

307:    Output parameter:
308: .  lev - level of orthogonality (optional)

310:    Notes: 
311:    This function computes W'*V and prints the result. It is intended to check
312:    the level of bi-orthogonality of the vectors in the two sets. If W is equal
313:    to PETSC_NULL then V is used, thus checking the orthogonality of the V vectors.

315:    If matrix B is provided then the check uses the B-inner product, W'*B*V.

317:    If lev is not PETSC_NULL, it will contain the level of orthogonality
318:    computed as ||W'*V - I|| in the Frobenius norm. Otherwise, the matrix W'*V
319:    is printed.

321:    Level: developer

323: @*/
324: PetscErrorCode SlepcCheckOrthogonality(Vec *V,PetscInt nv,Vec *W,PetscInt nw,Mat B,PetscScalar *lev)
325: {
327:   PetscInt       i,j;
328:   PetscScalar    *vals;
329:   Vec            w;
330:   MPI_Comm       comm;

333:   if (nv<=0 || nw<=0) return(0);
334:   PetscObjectGetComm((PetscObject)V[0],&comm);
335:   PetscMalloc(nv*sizeof(PetscScalar),&vals);
336:   if (B) { VecDuplicate(V[0],&w); }
337:   if (lev) *lev = 0.0;
338:   for (i=0;i<nw;i++) {
339:     if (B) {
340:       if (W) { MatMultTranspose(B,W[i],w); }
341:       else { MatMultTranspose(B,V[i],w); }
342:     }
343:     else {
344:       if (W) w = W[i];
345:       else w = V[i];
346:     }
347:     VecMDot(w,nv,V,vals);
348:     for (j=0;j<nv;j++) {
349:       if (lev) *lev += (j==i)? (vals[j]-1.0)*(vals[j]-1.0): vals[j]*vals[j];
350:       else {
351: #ifndef PETSC_USE_COMPLEX
352:         PetscPrintf(comm," %12g  ",vals[j]);
353: #else
354:         PetscPrintf(comm," %12g%+12gi ",PetscRealPart(vals[j]),PetscImaginaryPart(vals[j]));
355: #endif
356:       }
357:     }
358:     if (!lev) { PetscPrintf(comm,"\n"); }
359:   }
360:   PetscFree(vals);
361:   if (B) { VecDestroy(w); }
362:   if (lev) *lev = PetscSqrtScalar(*lev);
363:   return(0);
364: }

368: /*@
369:    SlepcUpdateVectors - Update a set of vectors V as V(:,s:e-1) = V*Q(:,s:e-1).

371:    Collective on Vec

373:    Input parameters:
374: +  n      - number of vectors in V
375: .  s      - first column of V to be overwritten
376: .  e      - first column of V not to be overwritten
377: .  Q      - matrix containing the coefficients of the update
378: .  ldq    - leading dimension of Q
379: -  qtrans - flag indicating if Q is to be transposed

381:    Input/Output parameter:
382: .  V      - set of vectors

384:    Notes: 
385:    This function computes V(:,s:e-1) = V*Q(:,s:e-1), that is, given a set of
386:    vectors V, columns from s to e-1 are overwritten with columns from s to
387:    e-1 of the matrix-matrix product V*Q.

389:    Matrix V is represented as an array of Vec, whereas Q is represented as
390:    a column-major dense array of leading dimension ldq. Only columns s to e-1
391:    of Q are referenced.

393:    If qtrans=PETSC_TRUE, the operation is V*Q'.

395:    This routine is implemented with a call to BLAS, therefore V is an array 
396:    of Vec which have the data stored contiguously in memory as a Fortran matrix.
397:    PETSc does not create such arrays by default.

399:    Level: developer

401: @*/
402: PetscErrorCode SlepcUpdateVectors(PetscInt n_,Vec *V,PetscInt s,PetscInt e,const PetscScalar *Q,PetscInt ldq_,PetscTruth qtrans)
403: {


408:   SlepcUpdateStrideVectors(n_,V,s,1,e,Q,ldq_,qtrans);
409: 
410:   return(0);
411: }

415: /*@
416:    SlepcUpdateStrideVectors - Update a set of vectors V as
417:    V(:,s:d:e-1) = V*Q(:,s:e-1).

419:    Collective on Vec

421:    Input parameters:
422: +  n      - number of vectors in V
423: .  s      - first column of V to be overwritten
424: .  d      - stride
425: .  e      - first column of V not to be overwritten
426: .  Q      - matrix containing the coefficients of the update
427: .  ldq    - leading dimension of Q
428: -  qtrans - flag indicating if Q is to be transposed

430:    Input/Output parameter:
431: .  V      - set of vectors

433:    Notes: 
434:    This function computes V(:,s:d:e-1) = V*Q(:,s:e-1), that is, given a set
435:    of vectors V, columns from s to e-1 are overwritten with columns from s to
436:    e-1 of the matrix-matrix product V*Q.

438:    Matrix V is represented as an array of Vec, whereas Q is represented as
439:    a column-major dense array of leading dimension ldq. Only columns s to e-1
440:    of Q are referenced.

442:    If qtrans=PETSC_TRUE, the operation is V*Q'.

444:    This routine is implemented with a call to BLAS, therefore V is an array 
445:    of Vec which have the data stored contiguously in memory as a Fortran matrix.
446:    PETSc does not create such arrays by default.

448:    Level: developer

450: @*/
451: PetscErrorCode SlepcUpdateStrideVectors(PetscInt n_,Vec *V,PetscInt s,PetscInt d,PetscInt e,const PetscScalar *Q,PetscInt ldq_,PetscTruth qtrans)
452: {
454:   PetscInt       l;
455:   PetscBLASInt   i,j,k,bs=64,m,n,ldq,ls,ld;
456:   PetscScalar    *pv,*pw,*pq,*work,*pwork,one=1.0,zero=0.0;
457:   const char     *qt;

460:   n = PetscBLASIntCast(n_/d);
461:   ldq = PetscBLASIntCast(ldq_);
462:   m = (e-s)/d;
463:   if (m==0) return(0);
465:   if (m<0 || n<0 || s<0 || m>n) SETERRQ(PETSC_ERR_ARG_OUTOFRANGE,"Index argument out of range");
466:   PetscLogEventBegin(SLEPC_UpdateVectors,0,0,0,0);
467:   VecGetLocalSize(V[0],&l);
468:   ls = PetscBLASIntCast(l);
469:   ld = ls*PetscBLASIntCast(d);
470:   VecGetArray(V[0],&pv);
471:   if (qtrans) {
472:     pq = (PetscScalar*)Q+s;
473:     qt = "T";
474:   } else {
475:     pq = (PetscScalar*)Q+s*ldq;
476:     qt = "N";
477:   }
478:   PetscMalloc(sizeof(PetscScalar)*bs*m,&work);
479:   k = ls % bs;
480:   if (k) {
481:     BLASgemm_("N",qt,&k,&m,&n,&one,pv,&ld,pq,&ldq,&zero,work,&k);
482:     for (j=0;j<m;j++) {
483:       pw = pv+(s+j)*ld;
484:       pwork = work+j*k;
485:       for (i=0;i<k;i++) {
486:         *pw++ = *pwork++;
487:       }
488:     }
489:   }
490:   for (;k<ls;k+=bs) {
491:     BLASgemm_("N",qt,&bs,&m,&n,&one,pv+k,&ld,pq,&ldq,&zero,work,&bs);
492:     for (j=0;j<m;j++) {
493:       pw = pv+(s+j)*ld+k;
494:       pwork = work+j*bs;
495:       for (i=0;i<bs;i++) {
496:         *pw++ = *pwork++;
497:       }
498:     }
499:   }
500:   VecRestoreArray(V[0],&pv);
501:   PetscFree(work);
502:   PetscLogFlops(m*n*2.0*ls);
503:   PetscLogEventEnd(SLEPC_UpdateVectors,0,0,0,0);
504:   return(0);
505: }

509: /*@
510:    SlepcVecMAXPBY - Computes y = beta*y + sum alpha*a[j]*x[j]

512:    Collective on Vec

514:    Input parameters:
515: +  beta   - scalar beta
516: .  alpha  - scalar alpha
517: .  nv     - number of vectors in x and scalars in a
518: .  a      - array of scalars
519: -  x      - set of vectors

521:    Input/Output parameter:
522: .  y      - the vector to update

524:    Notes:
525:    This routine is implemented with a call to BLAS, therefore x is an array 
526:    of Vec which have the data stored contiguously in memory as a Fortran matrix.
527:    PETSc does not create such arrays by default.

529:    Level: developer

531: @*/
532: PetscErrorCode SlepcVecMAXPBY(Vec y,PetscScalar beta,PetscScalar alpha,PetscInt nv,PetscScalar a[],Vec x[])
533: {
535:   PetscBLASInt   n,m,one=1;
536:   PetscScalar    *py,*px;

540:   if (!nv || !(y)->map->n) return(0);
541:   if (nv < 0) SETERRQ1(PETSC_ERR_ARG_OUTOFRANGE,"Number of vectors (given %D) cannot be negative",nv);
548:   if ((*x)->map->N != (y)->map->N) SETERRQ(PETSC_ERR_ARG_INCOMP,"Incompatible vector global lengths");
549:   if ((*x)->map->n != (y)->map->n) SETERRQ(PETSC_ERR_ARG_INCOMP,"Incompatible vector local lengths");

551:   PetscLogEventBegin(SLEPC_VecMAXPBY,*x,y,0,0);
552:   VecGetArray(y,&py);
553:   VecGetArray(*x,&px);
554:   n = PetscBLASIntCast(nv);
555:   m = PetscBLASIntCast((y)->map->n);
556:   BLASgemv_("N",&m,&n,&alpha,px,&m,a,&one,&beta,py,&one);
557:   VecRestoreArray(y,&py);
558:   VecRestoreArray(*x,&px);
559:   PetscLogFlops(nv*2*(y)->map->n);
560:   PetscLogEventEnd(SLEPC_VecMAXPBY,*x,y,0,0);
561:   return(0);
562: }