Date: 2013-09-02T10:08:41+00:00

Actual source code: ipbiorthog.c

      1: /*
      2:      Routines related to bi-orthogonalization.
      3:      See the SLEPc Technical Report STR-1 for a detailed explanation.

      5:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      6:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      7:    Copyright (c) 2002-2013, Universitat Politecnica de Valencia, Spain

      9:    This file is part of SLEPc.

     11:    SLEPc is free software: you can redistribute it and/or modify it under  the
     12:    terms of version 3 of the GNU Lesser General Public License as published by
     13:    the Free Software Foundation.

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

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

     25: #include <slepc-private/ipimpl.h>      /*I "slepcip.h" I*/
     26: #include <slepcblaslapack.h>

     28: /*
     29:     Biorthogonalization routine using classical Gram-Schmidt with refinement.
     30:  */
     33: static PetscErrorCode IPCGSBiOrthogonalization(IP ip,PetscInt n_,Vec *V,Vec *W,Vec v,PetscScalar *H,PetscReal *hnorm,PetscReal *norm)
     34: {
     35: #if defined(SLEPC_MISSING_LAPACK_GELQF) || defined(SLEPC_MISSING_LAPACK_ORMLQ)
     37:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GELQF/ORMLQ - Lapack routine is unavailable");
     38: #else
     40:   PetscBLASInt   j,ione=1,lwork,info,n=n_;
     41:   PetscScalar    shh[100],*lhh,*vw,*tau,one=1.0,*work;

     44:   /* Don't allocate small arrays */
     45:   if (n<=100) lhh = shh;
     46:   else {
     47:     PetscMalloc(n*sizeof(PetscScalar),&lhh);
     48:   }
     49:   PetscMalloc(n*n*sizeof(PetscScalar),&vw);

     51:   for (j=0;j<n;j++) {
     52:     IPMInnerProduct(ip,V[j],n,W,vw+j*n);
     53:   }
     54:   lwork = n;
     55:   PetscMalloc(n*sizeof(PetscScalar),&tau);
     56:   PetscMalloc(lwork*sizeof(PetscScalar),&work);
     57:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
     58:   PetscStackCallBLAS("LAPACKgelqf",LAPACKgelqf_(&n,&n,vw,&n,tau,work,&lwork,&info));
     59:   PetscFPTrapPop();
     60:   if (info) SETERRQ1(PetscObjectComm((PetscObject)ip),PETSC_ERR_LIB,"Error in Lapack xGELQF %d",info);

     62:   /*** First orthogonalization ***/

     64:   /* h = W^* v */
     65:   /* q = v - V h */
     66:   IPMInnerProduct(ip,v,n,W,H);
     67:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
     68:   PetscStackCallBLAS("BLAStrsm",BLAStrsm_("L","L","N","N",&n,&ione,&one,vw,&n,H,&n));
     69:   PetscStackCallBLAS("LAPACKormlq",LAPACKormlq_("L","N",&n,&ione,&n,vw,&n,tau,H,&n,work,&lwork,&info));
     70:   PetscFPTrapPop();
     71:   if (info) SETERRQ1(PetscObjectComm((PetscObject)ip),PETSC_ERR_LIB,"Error in Lapack xORMLQ %d",info);
     72:   SlepcVecMAXPBY(v,1.0,-1.0,n,H,V);

     74:   /* compute norm of v */
     75:   if (norm) { IPNorm(ip,v,norm); }

     77:   if (n>100) { PetscFree(lhh); }
     78:   PetscFree(vw);
     79:   PetscFree(tau);
     80:   PetscFree(work);
     81:   return(0);
     82: #endif
     83: }

     87: /*@
     88:    IPBiOrthogonalize - Bi-orthogonalize a vector with respect to a set of vectors.

     90:    Collective on IP and Vec

     92:    Input Parameters:
     93: +  ip - the inner product context
     94: .  n - number of columns of V
     95: .  V - set of vectors
     96: -  W - set of vectors

     98:    Input/Output Parameter:
     99: .  v - vector to be orthogonalized

    101:    Output Parameter:
    102: +  H  - coefficients computed during orthogonalization
    103: -  norm - norm of the vector after being orthogonalized

    105:    Notes:
    106:    This function applies an oblique projector to project vector v onto the
    107:    span of the columns of V along the orthogonal complement of the column
    108:    space of W.

    110:    On exit, v0 = [V v]*H, where v0 is the original vector v.

    112:    This routine does not normalize the resulting vector.

    114:    Level: developer

    116: .seealso: IPSetOrthogonalization(), IPOrthogonalize()
    117: @*/
    118: PetscErrorCode IPBiOrthogonalize(IP ip,PetscInt n,Vec *V,Vec *W,Vec v,PetscScalar *H,PetscReal *norm)
    119: {
    121:   PetscScalar    lh[100],*h;
    122:   PetscBool      allocated = PETSC_FALSE;
    123:   PetscReal      lhnrm,*hnrm,lnrm,*nrm;

    128:   if (!n) {
    129:     if (norm) { IPNorm(ip,v,norm); }
    130:   } else {
    131:     PetscLogEventBegin(IP_Orthogonalize,ip,0,0,0);
    132:     /* allocate H if needed */
    133:     if (!H) {
    134:       if (n<=100) h = lh;
    135:       else {
    136:         PetscMalloc(n*sizeof(PetscScalar),&h);
    137:         allocated = PETSC_TRUE;
    138:       }
    139:     } else h = H;

    141:     /* retrieve hnrm and nrm for linear dependence check or conditional refinement */
    142:     if (ip->orthog_ref == IP_ORTHOG_REFINE_IFNEEDED) {
    143:       hnrm = &lhnrm;
    144:       if (norm) nrm = norm;
    145:       else nrm = &lnrm;
    146:     } else {
    147:       hnrm = NULL;
    148:       nrm = norm;
    149:     }

    151:     switch (ip->orthog_type) {
    152:       case IP_ORTHOG_CGS:
    153:         IPCGSBiOrthogonalization(ip,n,V,W,v,h,hnrm,nrm);
    154:         break;
    155:       default:
    156:         SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_ARG_WRONG,"Unknown orthogonalization type");
    157:     }

    159:     if (allocated) { PetscFree(h); }
    160:     PetscLogEventEnd(IP_Orthogonalize,ip,0,0,0);
    161:   }
    162:   return(0);
    163: }

    165: /*
    166:    IPPseudoOrthogonalizeCGS1 - Compute |v'| (estimated), |v| and one step of CGS with only one global synchronization (indefinite)
    167: */
    170: PetscErrorCode IPPseudoOrthogonalizeCGS1(IP ip,PetscInt n,Vec *V,PetscReal* omega,Vec v,PetscScalar *H,PetscReal *onorm,PetscReal *norm)
    171: {
    173:   PetscInt       j;
    174:   PetscScalar    alpha;
    175:   PetscReal      sum;

    178:   /* h = W^* v ; alpha = (v , v) */
    179:   if (!onorm && !norm) {
    180:     /* use simpler function */
    181:     IPMInnerProduct(ip,v,n,V,H);
    182:   } else {
    183:     /* merge comunications */
    184:     IPMInnerProductBegin(ip,v,n,V,H);
    185:     if (onorm || (norm && !ip->matrix)) {
    186:       IPInnerProductBegin(ip,v,v,&alpha);
    187:     }

    189:     IPMInnerProductEnd(ip,v,n,V,H);
    190:     if (onorm || (norm && !ip->matrix)) {
    191:       IPInnerProductEnd(ip,v,v,&alpha);
    192:     }
    193:   }

    195:   /* q = v - V h */
    196:   for (j=0;j<n;j++) H[j] /= omega[j];  /* apply inverse of signature */
    197:   SlepcVecMAXPBY(v,1.0,-1.0,n,H,V);
    198:   for (j=0;j<n;j++) H[j] *= omega[j];  /* revert signature */

    200:   /* compute |v| */
    201:   if (onorm) {
    202:     if (PetscRealPart(alpha)>0.0) *onorm = PetscSqrtReal(PetscRealPart(alpha));
    203:     else *onorm = -PetscSqrtReal(-PetscRealPart(alpha));
    204:   }

    206:   if (norm) {
    207:     if (!ip->matrix) {
    208:       /* estimate |v'| from |v| */
    209:       sum = 0.0;
    210:       for (j=0; j<n; j++)
    211:         sum += PetscRealPart(H[j] * PetscConj(H[j]));
    212:       *norm = PetscRealPart(alpha)-sum;
    213:       if (*norm <= 0.0) {
    214:         IPNorm(ip,v,norm);
    215:       } else *norm = PetscSqrtReal(*norm);
    216:     } else {
    217:       /* compute |v'| */
    218:       IPNorm(ip,v,norm);
    219:     }
    220:   }
    221:   return(0);
    222: }

    224: /*
    225:   IPPseudoOrthogonalizeCGS - Orthogonalize with classical Gram-Schmidt (indefinite)
    226: */
    229: static PetscErrorCode IPPseudoOrthogonalizeCGS(IP ip,PetscInt n,Vec *V,PetscReal *omega,Vec v,PetscScalar *H,PetscReal *norm,PetscBool *lindep)
    230: {
    232:   PetscScalar    *h,*c;
    233:   PetscReal      onrm,nrm;
    234:   PetscInt       sz=0,sz1,j,k;

    237:   /* allocate h and c if needed */
    238:   if (!H) sz = n;
    239:   sz1 = sz;
    240:   if (ip->orthog_ref != IP_ORTHOG_REFINE_NEVER) sz += n;
    241:   if (sz>ip->lwork) {
    242:     PetscFree(ip->work);
    243:     PetscMalloc(sz*sizeof(PetscScalar),&ip->work);
    244:     PetscLogObjectMemory(ip,(sz-ip->lwork)*sizeof(PetscScalar));
    245:     ip->lwork = sz;
    246:   }
    247:   if (!H) h = ip->work;
    248:   else h = H;
    249:   if (ip->orthog_ref != IP_ORTHOG_REFINE_NEVER) c = ip->work + sz1;

    251:   /* orthogonalize and compute onorm */
    252:   switch (ip->orthog_ref) {

    254:   case IP_ORTHOG_REFINE_NEVER:
    255:     IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,h,NULL,NULL);
    256:     /* compute |v| */
    257:     if (norm) { IPNorm(ip,v,norm); }
    258:     /* linear dependence check does not work without refinement */
    259:     if (lindep) *lindep = PETSC_FALSE;
    260:     break;

    262:   case IP_ORTHOG_REFINE_ALWAYS:
    263:     IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,h,NULL,NULL);
    264:     if (lindep) {
    265:       IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,&onrm,&nrm);
    266:       if (norm) *norm = nrm;
    267:       if (PetscAbs(nrm) < ip->orthog_eta * PetscAbs(onrm)) *lindep = PETSC_TRUE;
    268:       else *lindep = PETSC_FALSE;
    269:     } else {
    270:       IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,NULL,norm);
    271:     }
    272:     for (j=0;j<n;j++)
    273:       h[j] += c[j];
    274:     break;

    276:   case IP_ORTHOG_REFINE_IFNEEDED:
    277:     IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,h,&onrm,&nrm);
    278:     /* ||q|| < eta ||h|| */
    279:     k = 1;
    280:     while (k<3 && PetscAbs(nrm) < ip->orthog_eta * PetscAbs(onrm)) {
    281:       k++;
    282:       if (!ip->matrix) {
    283:         IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,&onrm,&nrm);
    284:       } else {
    285:         onrm = nrm;
    286:         IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,NULL,&nrm);
    287:       }
    288:       for (j=0;j<n;j++)
    289:         h[j] += c[j];
    290:     }
    291:     if (norm) *norm = nrm;
    292:     if (lindep) {
    293:       if (PetscAbs(nrm) < ip->orthog_eta * PetscAbs(onrm)) *lindep = PETSC_TRUE;
    294:       else *lindep = PETSC_FALSE;
    295:     }
    296:     break;

    298:   default:
    299:     SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_ARG_WRONG,"Unknown orthogonalization refinement");
    300:   }

    302:   /* recover H from workspace */
    303:   if (H) {
    304:     for (j=0;j<n;j++)
    305:       H[j] = h[j];
    306:   }
    307:   return(0);
    308: }

    312: /*@
    313:    IPPseudoOrthogonalize - Orthogonalize a vector with respect to two set of vectors
    314:    in the sense of a pseudo-inner product.

    316:    Collective on IP and Vec

    318:    Input Parameters:
    319: +  ip     - the inner product (IP) context
    320: .  n      - number of columns of V
    321: .  V      - set of vectors
    322: -  omega  - set of signs that define a signature matrix

    324:    Input/Output Parameter:
    325: .  v      - (input) vector to be orthogonalized and (output) result of
    326:             orthogonalization

    328:    Output Parameter:
    329: +  H      - coefficients computed during orthogonalization
    330: .  norm   - norm of the vector after being orthogonalized
    331: -  lindep - flag indicating that refinement did not improve the quality
    332:             of orthogonalization

    334:    Notes:
    335:    This function is the analogue of IPOrthogonalize, but for the indefinite
    336:    case. When using an indefinite IP the norm is not well defined, so we
    337:    take the convention of having negative norms in such cases. The
    338:    orthogonalization is then defined by a set of vectors V satisfying
    339:    V'*B*V=Omega, where Omega is a signature matrix diag([+/-1,...,+/-1]).

    341:    On exit, v = v0 - V*Omega*H, where v0 is the original vector v.

    343:    This routine does not normalize the resulting vector. The output
    344:    argument 'norm' may be negative.

    346:    Level: developer

    348: .seealso: IPSetOrthogonalization(), IPOrthogonalize()
    349: @*/
    350: PetscErrorCode IPPseudoOrthogonalize(IP ip,PetscInt n,Vec *V,PetscReal *omega,Vec v,PetscScalar *H,PetscReal *norm,PetscBool *lindep)
    351: {

    357:   PetscLogEventBegin(IP_Orthogonalize,ip,0,0,0);
    358:   if (n==0) {
    359:     if (norm) { IPNorm(ip,v,norm); }
    360:     if (lindep) *lindep = PETSC_FALSE;
    361:   } else {
    362:     switch (ip->orthog_type) {
    363:     case IP_ORTHOG_CGS:
    364:       IPPseudoOrthogonalizeCGS(ip,n,V,omega,v,H,norm,lindep);
    365:       break;
    366:     case IP_ORTHOG_MGS:
    367:       SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_SUP,"Modified Gram-Schmidt not implemented for indefinite case");
    368:       break;
    369:     default:
    370:       SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_ARG_WRONG,"Unknown orthogonalization type");
    371:     }
    372:   }
    373:   PetscLogEventEnd(IP_Orthogonalize,ip,0,0,0);
    374:   return(0);
    375: }