Date: 2023-11-27T17:19:12+00:00

Actual source code: svdscalap.c
slepc-3.20.1 2023-11-27
Report Typos and Errors

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

      6:    This file is part of SLEPc.
      7:    SLEPc is distributed under a 2-clause BSD license (see LICENSE).
      8:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      9: */
     10: /*
     11:    This file implements a wrapper to the ScaLAPACK SVD solver
     12: */

     14: #include <slepc/private/svdimpl.h>
     15: #include <slepc/private/slepcscalapack.h>

     17: typedef struct {
     18:   Mat As;        /* converted matrix */
     19: } SVD_ScaLAPACK;

     21: static PetscErrorCode SVDSetUp_ScaLAPACK(SVD svd)
     22: {
     23:   SVD_ScaLAPACK  *ctx = (SVD_ScaLAPACK*)svd->data;
     24:   PetscInt       M,N;

     26:   PetscFunctionBegin;
     27:   SVDCheckStandard(svd);
     28:   SVDCheckDefinite(svd);
     29:   PetscCall(MatGetSize(svd->A,&M,&N));
     30:   svd->ncv = N;
     31:   if (svd->mpd!=PETSC_DEFAULT) PetscCall(PetscInfo(svd,"Warning: parameter mpd ignored\n"));
     32:   if (svd->max_it==PETSC_DEFAULT) svd->max_it = 1;
     33:   svd->leftbasis = PETSC_TRUE;
     34:   SVDCheckUnsupported(svd,SVD_FEATURE_STOPPING);
     35:   PetscCall(SVDAllocateSolution(svd,0));

     37:   /* convert matrix */
     38:   PetscCall(MatDestroy(&ctx->As));
     39:   PetscCall(MatConvert(svd->OP,MATSCALAPACK,MAT_INITIAL_MATRIX,&ctx->As));
     40:   PetscFunctionReturn(PETSC_SUCCESS);
     41: }

     43: static PetscErrorCode SVDSolve_ScaLAPACK(SVD svd)
     44: {
     45:   SVD_ScaLAPACK  *ctx = (SVD_ScaLAPACK*)svd->data;
     46:   Mat            A = ctx->As,Z,Q,QT,U,V;
     47:   Mat_ScaLAPACK  *a = (Mat_ScaLAPACK*)A->data,*q,*z;
     48:   PetscScalar    *work,minlwork;
     49:   PetscBLASInt   info,lwork=-1,one=1;
     50:   PetscInt       M,N,m,n,mn;
     51: #if defined(PETSC_USE_COMPLEX)
     52:   PetscBLASInt   lrwork;
     53:   PetscReal      *rwork,dummy;
     54: #endif

     56:   PetscFunctionBegin;
     57:   PetscCall(MatGetSize(A,&M,&N));
     58:   PetscCall(MatGetLocalSize(A,&m,&n));
     59:   mn = (M>=N)? n: m;
     60:   PetscCall(MatCreate(PetscObjectComm((PetscObject)A),&Z));
     61:   PetscCall(MatSetSizes(Z,m,mn,PETSC_DECIDE,PETSC_DECIDE));
     62:   PetscCall(MatSetType(Z,MATSCALAPACK));
     63:   PetscCall(MatSetUp(Z));
     64:   PetscCall(MatAssemblyBegin(Z,MAT_FINAL_ASSEMBLY));
     65:   PetscCall(MatAssemblyEnd(Z,MAT_FINAL_ASSEMBLY));
     66:   z = (Mat_ScaLAPACK*)Z->data;
     67:   PetscCall(MatCreate(PetscObjectComm((PetscObject)A),&QT));
     68:   PetscCall(MatSetSizes(QT,mn,n,PETSC_DECIDE,PETSC_DECIDE));
     69:   PetscCall(MatSetType(QT,MATSCALAPACK));
     70:   PetscCall(MatSetUp(QT));
     71:   PetscCall(MatAssemblyBegin(QT,MAT_FINAL_ASSEMBLY));
     72:   PetscCall(MatAssemblyEnd(QT,MAT_FINAL_ASSEMBLY));
     73:   q = (Mat_ScaLAPACK*)QT->data;

     75:   PetscCall(PetscFPTrapPush(PETSC_FP_TRAP_OFF));
     76: #if !defined(PETSC_USE_COMPLEX)
     77:   /* allocate workspace */
     78:   PetscCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,&minlwork,&lwork,&info));
     79:   PetscCheckScaLapackInfo("gesvd",info);
     80:   PetscCall(PetscBLASIntCast((PetscInt)minlwork,&lwork));
     81:   PetscCall(PetscMalloc1(lwork,&work));
     82:   /* call computational routine */
     83:   PetscCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,work,&lwork,&info));
     84:   PetscCheckScaLapackInfo("gesvd",info);
     85:   PetscCall(PetscFree(work));
     86: #else
     87:   /* allocate workspace */
     88:   PetscCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,&minlwork,&lwork,&dummy,&info));
     89:   PetscCheckScaLapackInfo("gesvd",info);
     90:   PetscCall(PetscBLASIntCast((PetscInt)PetscRealPart(minlwork),&lwork));
     91:   lrwork = 1+4*PetscMax(a->M,a->N);
     92:   PetscCall(PetscMalloc2(lwork,&work,lrwork,&rwork));
     93:   /* call computational routine */
     94:   PetscCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,work,&lwork,rwork,&info));
     95:   PetscCheckScaLapackInfo("gesvd",info);
     96:   PetscCall(PetscFree2(work,rwork));
     97: #endif
     98:   PetscCall(PetscFPTrapPop());

    100:   PetscCall(MatHermitianTranspose(QT,MAT_INITIAL_MATRIX,&Q));
    101:   PetscCall(MatDestroy(&QT));
    102:   PetscCall(BVGetMat(svd->U,&U));
    103:   PetscCall(BVGetMat(svd->V,&V));
    104:   if (M>=N) {
    105:     PetscCall(MatConvert(Z,MATDENSE,MAT_REUSE_MATRIX,&U));
    106:     PetscCall(MatConvert(Q,MATDENSE,MAT_REUSE_MATRIX,&V));
    107:   } else {
    108:     PetscCall(MatConvert(Q,MATDENSE,MAT_REUSE_MATRIX,&U));
    109:     PetscCall(MatConvert(Z,MATDENSE,MAT_REUSE_MATRIX,&V));
    110:   }
    111:   PetscCall(BVRestoreMat(svd->U,&U));
    112:   PetscCall(BVRestoreMat(svd->V,&V));
    113:   PetscCall(MatDestroy(&Z));
    114:   PetscCall(MatDestroy(&Q));

    116:   svd->nconv  = svd->ncv;
    117:   svd->its    = 1;
    118:   svd->reason = SVD_CONVERGED_TOL;
    119:   PetscFunctionReturn(PETSC_SUCCESS);
    120: }

    122: static PetscErrorCode SVDDestroy_ScaLAPACK(SVD svd)
    123: {
    124:   PetscFunctionBegin;
    125:   PetscCall(PetscFree(svd->data));
    126:   PetscFunctionReturn(PETSC_SUCCESS);
    127: }

    129: static PetscErrorCode SVDReset_ScaLAPACK(SVD svd)
    130: {
    131:   SVD_ScaLAPACK  *ctx = (SVD_ScaLAPACK*)svd->data;

    133:   PetscFunctionBegin;
    134:   PetscCall(MatDestroy(&ctx->As));
    135:   PetscFunctionReturn(PETSC_SUCCESS);
    136: }

    138: SLEPC_EXTERN PetscErrorCode SVDCreate_ScaLAPACK(SVD svd)
    139: {
    140:   SVD_ScaLAPACK  *ctx;

    142:   PetscFunctionBegin;
    143:   PetscCall(PetscNew(&ctx));
    144:   svd->data = (void*)ctx;

    146:   svd->ops->solve          = SVDSolve_ScaLAPACK;
    147:   svd->ops->setup          = SVDSetUp_ScaLAPACK;
    148:   svd->ops->destroy        = SVDDestroy_ScaLAPACK;
    149:   svd->ops->reset          = SVDReset_ScaLAPACK;
    150:   PetscFunctionReturn(PETSC_SUCCESS);
    151: }