Date: 2017-05-17T08:26:54+00:00

Actual source code: pepkrylov.c
slepc-3.7.4 2017-05-17
Report Typos and Errors

      1: /*
      2:    Common subroutines for all Krylov-type PEP solvers.

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

      8:    This file is part of SLEPc.

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

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

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

     24: #include <slepc/private/pepimpl.h>    /*I "slepcpep.h" I*/
     25: #include <slepcblaslapack.h>
     26:  #include pepkrylov.h

     30: PetscErrorCode PEPExtractVectors_TOAR(PEP pep)
     31: {
     33:   PetscInt       i,j,deg=pep->nmat-1,lds,idxcpy=0,ldds,k,ld;
     34:   PetscScalar    *X,*er,*ei,*SS,*vals,*ivals,sone=1.0,szero=0.0,*yi,*yr,*tr,*ti,alpha,t,*S,*pS0;
     35:   PetscBLASInt   k_,lds_,one=1,ldds_;
     36:   PetscBool      flg;
     37:   PetscReal      norm,max,factor=1.0;
     38:   Vec            xr,xi,w[4];
     39:   PEP_TOAR       *ctx = (PEP_TOAR*)pep->data;
     40:   Mat            S0;

     43:   S = ctx->S;
     44:   ld = ctx->ld;
     45:   k = pep->nconv;
     46:   if (k==0) return(0);
     47:   lds = deg*ld;
     48:   DSGetLeadingDimension(pep->ds,&ldds);
     49:   PetscCalloc5(k,&er,k,&ei,k*k,&SS,pep->nmat,&vals,pep->nmat,&ivals);
     50:   STGetTransform(pep->st,&flg);
     51:   if (flg) factor = pep->sfactor;
     52:   for (i=0;i<k;i++) {
     53:     er[i] = factor*pep->eigr[i];
     54:     ei[i] = factor*pep->eigi[i];
     55:   }
     56:   STBackTransform(pep->st,k,er,ei);

     58:   DSVectors(pep->ds,DS_MAT_X,NULL,NULL);
     59:   DSGetArray(pep->ds,DS_MAT_X,&X);

     61:   PetscBLASIntCast(k,&k_);
     62:   PetscBLASIntCast(lds,&lds_);
     63:   PetscBLASIntCast(ldds,&ldds_);

     65:   if (pep->extract==PEP_EXTRACT_NONE || pep->refine==PEP_REFINE_MULTIPLE) {
     66:     PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&k_,&k_,&k_,&sone,S,&lds_,X,&ldds_,&szero,SS,&k_));
     67:   } else {
     68:     switch (pep->extract) {
     69:     case PEP_EXTRACT_NONE:
     70:       break;
     71:     case PEP_EXTRACT_NORM:
     72:       for (i=0;i<k;i++) {
     73:         PEPEvaluateBasis(pep,er[i],ei[i],vals,ivals);
     74:         max = 1.0;
     75:         for (j=1;j<deg;j++) {
     76:           norm = SlepcAbsEigenvalue(vals[j],ivals[j]);
     77:           if (max < norm) { max = norm; idxcpy = j; }
     78:         }
     79:         PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&sone,S+idxcpy*ld,&lds_,X+i*ldds,&one,&szero,SS+i*k,&one));
     80: #if !defined(PETSC_USE_COMPLEX)
     81:         if (PetscRealPart(ei[i])!=0.0) {
     82:           i++;
     83:           PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&sone,S+idxcpy*ld,&lds_,X+i*ldds,&one,&szero,SS+i*k,&one));
     84:         }
     85: #endif
     86:       }
     87:       break;
     88:     case PEP_EXTRACT_RESIDUAL:
     89:       VecDuplicate(pep->work[0],&xr);
     90:       VecDuplicate(pep->work[0],&w[0]);
     91:       VecDuplicate(pep->work[0],&w[1]);
     92: #if !defined(PETSC_USE_COMPLEX)
     93:       VecDuplicate(pep->work[0],&w[2]);
     94:       VecDuplicate(pep->work[0],&w[3]);
     95:       VecDuplicate(pep->work[0],&xi);
     96: #else
     97:       xi = NULL;
     98: #endif
     99:       for (i=0;i<k;i++) {
    100:         max = 0.0;
    101:         for (j=0;j<deg;j++) {
    102:           PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&sone,S+j*ld,&lds_,X+i*ldds,&one,&szero,SS+i*k,&one));
    103:           BVMultVec(pep->V,1.0,0.0,xr,SS+i*k);
    104: #if !defined(PETSC_USE_COMPLEX)
    105:           PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&sone,S+j*ld,&lds_,X+(i+1)*ldds,&one,&szero,SS+i*k,&one));
    106:           BVMultVec(pep->V,1.0,0.0,xi,SS+i*k);
    107: #endif
    108:           PEPComputeResidualNorm_Private(pep,er[i],ei[i],xr,xi,w,&norm);
    109:           if (norm>max) { max = norm; idxcpy=j; }
    110:         }
    111:         PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&sone,S+idxcpy*ld,&lds_,X+i*ldds,&one,&szero,SS+i*k,&one));
    112: #if !defined(PETSC_USE_COMPLEX)
    113:         if (PetscRealPart(ei[i])!=0.0) {
    114:           i++;
    115:           PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&sone,S+idxcpy*ld,&lds_,X+i*ldds,&one,&szero,SS+i*k,&one));
    116:         }
    117: #endif
    118:       }
    119:       VecDestroy(&xr);
    120:       VecDestroy(&w[0]);
    121:       VecDestroy(&w[1]);
    122: #if !defined(PETSC_USE_COMPLEX)
    123:       VecDestroy(&w[2]);
    124:       VecDestroy(&w[3]);
    125:       VecDestroy(&xi);
    126: #endif
    127:       break;
    128:     case PEP_EXTRACT_STRUCTURED:
    129:       PetscMalloc2(k,&tr,k,&ti);
    130:       for (i=0;i<k;i++) {
    131:         t = 0.0;
    132:         PEPEvaluateBasis(pep,er[i],ei[i],vals,ivals);
    133:         yr = X+i*ldds; yi = NULL;
    134:         for (j=0;j<deg;j++) {
    135:           alpha = PetscConj(vals[j]);
    136: #if !defined(PETSC_USE_COMPLEX)
    137:           if (ei[i]!=0.0) {
    138:             PetscMemzero(tr,k*sizeof(PetscScalar));
    139:             PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&k_,&vals[j],X+i*ldds,&one,tr,&one));
    140:             PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&k_,&ivals[j],X+(i+1)*ldds,&one,tr,&one));
    141:             yr = tr;
    142:             PetscMemzero(ti,k*sizeof(PetscScalar));
    143:             PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&k_,&vals[j],X+(i+1)*ldds,&one,ti,&one));
    144:             alpha = -ivals[j];
    145:             PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&k_,&alpha,X+i*ldds,&one,ti,&one));
    146:             yi = ti;
    147:             alpha = 1.0;
    148:           } else { yr = X+i*ldds; yi = NULL; }
    149: #endif
    150:           PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&alpha,S+j*ld,&lds_,yr,&one,&sone,SS+i*k,&one));
    151:           t += SlepcAbsEigenvalue(vals[j],ivals[j])*SlepcAbsEigenvalue(vals[j],ivals[j]);
    152:           if (yi) {
    153:             PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&k_,&k_,&alpha,S+j*ld,&lds_,yi,&one,&sone,SS+(i+1)*k,&one));
    154:           }
    155:         }
    156:         t = 1.0/t;
    157:         PetscStackCallBLAS("BLASscal",BLASscal_(&k_,&t,SS+i*k,&one));
    158:         if (yi) {
    159:           PetscStackCallBLAS("BLASscal",BLASscal_(&k_,&t,SS+(i+1)*k,&one));
    160:           i++;
    161:         }
    162:       }
    163:       PetscFree2(tr,ti);
    164:       break;
    165:     default:
    166:         SETERRQ(PetscObjectComm((PetscObject)pep),PETSC_ERR_SUP,"Extraction not implemented in this solver");
    167:     }
    168:   }

    170:   /* update vectors V = V*S */
    171:   MatCreateSeqDense(PETSC_COMM_SELF,k,k,NULL,&S0);
    172:   MatDenseGetArray(S0,&pS0);
    173:   for (i=0;i<k;i++) {
    174:     PetscMemcpy(pS0+i*k,SS+i*k,k*sizeof(PetscScalar));
    175:   }
    176:   MatDenseRestoreArray(S0,&pS0);
    177:   BVMultInPlace(pep->V,S0,0,k);
    178:   MatDestroy(&S0);
    179:   PetscFree5(er,ei,SS,vals,ivals);
    180:   return(0);
    181: }

    185: PetscErrorCode PEPReset_TOAR(PEP pep)
    186: {
    187:   PEP_TOAR       *ctx = (PEP_TOAR*)pep->data;

    191:   PetscFree(ctx->S);
    192:   PetscFree(ctx->qB);
    193:   return(0);
    194: }