Date: 2015-10-02T22:21:11+00:00

Actual source code: gmreig.c
petsc-3.6.2 2015-10-02
Report Typos and Errors

      2: #include <../src/ksp/ksp/impls/gmres/gmresimpl.h>
      3: #include <petscblaslapack.h>

      7: PetscErrorCode KSPComputeExtremeSingularValues_GMRES(KSP ksp,PetscReal *emax,PetscReal *emin)
      8: {
      9: #if defined(PETSC_MISSING_LAPACK_GESVD)
     11:   /*
     12:       The Cray math libraries on T3D/T3E, and early versions of Intel Math Kernel Libraries (MKL)
     13:       for PCs do not seem to have the DGESVD() lapack routines
     14:   */
     15:   SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable\nNot able to provide singular value estimates.");
     16: #else
     17:   KSP_GMRES      *gmres = (KSP_GMRES*)ksp->data;
     19:   PetscInt       n = gmres->it + 1,i,N = gmres->max_k + 2;
     20:   PetscBLASInt   bn, bN,lwork, idummy,lierr;
     21:   PetscScalar    *R        = gmres->Rsvd,*work = R + N*N,sdummy;
     22:   PetscReal      *realpart = gmres->Dsvd;

     25:   PetscBLASIntCast(n,&bn);
     26:   PetscBLASIntCast(N,&bN);
     27:   PetscBLASIntCast(5*N,&lwork);
     28:   PetscBLASIntCast(N,&idummy);
     29:   if (n <= 0) {
     30:     *emax = *emin = 1.0;
     31:     return(0);
     32:   }
     33:   /* copy R matrix to work space */
     34:   PetscMemcpy(R,gmres->hh_origin,(gmres->max_k+2)*(gmres->max_k+1)*sizeof(PetscScalar));

     36:   /* zero below diagonal garbage */
     37:   for (i=0; i<n; i++) R[i*N+i+1] = 0.0;

     39:   /* compute Singular Values */
     40:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
     41: #if !defined(PETSC_USE_COMPLEX)
     42:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr));
     43: #else
     44:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,realpart+N,&lierr));
     45: #endif
     46:   if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in SVD Lapack routine %d",(int)lierr);
     47:   PetscFPTrapPop();

     49:   *emin = realpart[n-1];
     50:   *emax = realpart[0];
     51: #endif
     52:   return(0);
     53: }

     55: /* ------------------------------------------------------------------------ */
     56: /* ESSL has a different calling sequence for dgeev() and zgeev() than standard LAPACK */
     59: PetscErrorCode KSPComputeEigenvalues_GMRES(KSP ksp,PetscInt nmax,PetscReal *r,PetscReal *c,PetscInt *neig)
     60: {
     61: #if defined(PETSC_HAVE_ESSL)
     62:   KSP_GMRES      *gmres = (KSP_GMRES*)ksp->data;
     64:   PetscInt       n = gmres->it + 1,N = gmres->max_k + 1;
     65:   PetscInt       i,*perm;
     66:   PetscScalar    *R     = gmres->Rsvd;
     67:   PetscScalar    *cwork = R + N*N,sdummy;
     68:   PetscReal      *work,*realpart = gmres->Dsvd;
     69:   PetscBLASInt   zero = 0,bn,bN,idummy,lwork;

     72:   PetscBLASIntCast(n,&bn);
     73:   PetscBLASIntCast(N,&bN);
     74:   idummy = -1;                  /* unused */
     75:   PetscBLASIntCast(5*N,&lwork);
     76:   if (nmax < n) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
     77:   *neig = n;

     79:   if (!n) return(0);

     81:   /* copy R matrix to work space */
     82:   PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));

     84:   /* compute eigenvalues */

     86:   /* for ESSL version need really cwork of length N (complex), 2N
     87:      (real); already at least 5N of space has been allocated */

     89:   PetscMalloc1(lwork,&work);
     90:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
     91:   PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_(&zero,R,&bN,cwork,&sdummy,&idummy,&idummy,&bn,work,&lwork));
     92:   PetscFPTrapPop();
     93:   PetscFree(work);

     95:   /* For now we stick with the convention of storing the real and imaginary
     96:      components of evalues separately.  But is this what we really want? */
     97:   PetscMalloc1(n,&perm);

     99: #if !defined(PETSC_USE_COMPLEX)
    100:   for (i=0; i<n; i++) {
    101:     realpart[i] = cwork[2*i];
    102:     perm[i]     = i;
    103:   }
    104:   PetscSortRealWithPermutation(n,realpart,perm);
    105:   for (i=0; i<n; i++) {
    106:     r[i] = cwork[2*perm[i]];
    107:     c[i] = cwork[2*perm[i]+1];
    108:   }
    109: #else
    110:   for (i=0; i<n; i++) {
    111:     realpart[i] = PetscRealPart(cwork[i]);
    112:     perm[i]     = i;
    113:   }
    114:   PetscSortRealWithPermutation(n,realpart,perm);
    115:   for (i=0; i<n; i++) {
    116:     r[i] = PetscRealPart(cwork[perm[i]]);
    117:     c[i] = PetscImaginaryPart(cwork[perm[i]]);
    118:   }
    119: #endif
    120:   PetscFree(perm);
    121: #elif defined(PETSC_MISSING_LAPACK_GEEV)
    123:   SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
    124: #elif !defined(PETSC_USE_COMPLEX)
    125:   KSP_GMRES      *gmres = (KSP_GMRES*)ksp->data;
    127:   PetscInt       n = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
    128:   PetscBLASInt   bn, bN, lwork, idummy, lierr;
    129:   PetscScalar    *R        = gmres->Rsvd,*work = R + N*N;
    130:   PetscScalar    *realpart = gmres->Dsvd,*imagpart = realpart + N,sdummy;

    133:   PetscBLASIntCast(n,&bn);
    134:   PetscBLASIntCast(N,&bN);
    135:   PetscBLASIntCast(5*N,&lwork);
    136:   PetscBLASIntCast(N,&idummy);
    137:   if (nmax < n) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
    138:   *neig = n;

    140:   if (!n) return(0);

    142:   /* copy R matrix to work space */
    143:   PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));

    145:   /* compute eigenvalues */
    146:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    147:   PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_("N","N",&bn,R,&bN,realpart,imagpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr));
    148:   if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine %d",(int)lierr);
    149:   PetscFPTrapPop();
    150:   PetscMalloc1(n,&perm);
    151:   for (i=0; i<n; i++) perm[i] = i;
    152:   PetscSortRealWithPermutation(n,realpart,perm);
    153:   for (i=0; i<n; i++) {
    154:     r[i] = realpart[perm[i]];
    155:     c[i] = imagpart[perm[i]];
    156:   }
    157:   PetscFree(perm);
    158: #else
    159:   KSP_GMRES      *gmres = (KSP_GMRES*)ksp->data;
    161:   PetscInt       n  = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
    162:   PetscScalar    *R = gmres->Rsvd,*work = R + N*N,*eigs = work + 5*N,sdummy;
    163:   PetscBLASInt   bn,bN,lwork,idummy,lierr;

    166:   PetscBLASIntCast(n,&bn);
    167:   PetscBLASIntCast(N,&bN);
    168:   PetscBLASIntCast(5*N,&lwork);
    169:   PetscBLASIntCast(N,&idummy);
    170:   if (nmax < n) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
    171:   *neig = n;

    173:   if (!n) return(0);

    175:   /* copy R matrix to work space */
    176:   PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));

    178:   /* compute eigenvalues */
    179:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    180:   PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_("N","N",&bn,R,&bN,eigs,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,gmres->Dsvd,&lierr));
    181:   if (lierr) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine");
    182:   PetscFPTrapPop();
    183:   PetscMalloc1(n,&perm);
    184:   for (i=0; i<n; i++) perm[i] = i;
    185:   for (i=0; i<n; i++) r[i] = PetscRealPart(eigs[i]);
    186:   PetscSortRealWithPermutation(n,r,perm);
    187:   for (i=0; i<n; i++) {
    188:     r[i] = PetscRealPart(eigs[perm[i]]);
    189:     c[i] = PetscImaginaryPart(eigs[perm[i]]);
    190:   }
    191:   PetscFree(perm);
    192: #endif
    193:   return(0);
    194: }