Date: 2026-05-01T10:02:11+00:00

Actual source code: svdlapack.c

      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 LAPACK SVD subroutines
     12: */

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

     17: static PetscErrorCode SVDSetUp_LAPACK(SVD svd)
     18: {
     19:   PetscInt       M,N,P=0;

     21:   PetscFunctionBegin;
     22:   if (svd->nsv==0) svd->nsv = 1;
     23:   PetscCall(MatGetSize(svd->A,&M,&N));
     24:   if (!svd->isgeneralized) svd->ncv = N;
     25:   else {
     26:     PetscCall(MatGetSize(svd->OPb,&P,NULL));
     27:     svd->ncv = PetscMin(M,PetscMin(N,P));
     28:   }
     29:   if (svd->mpd!=PETSC_DETERMINE) PetscCall(PetscInfo(svd,"Warning: parameter mpd ignored\n"));
     30:   SVDCheckIgnored(svd,SVD_FEATURE_STOPPING);
     31:   if (svd->max_it==PETSC_DETERMINE) svd->max_it = 1;
     32:   svd->leftbasis = PETSC_TRUE;
     33:   PetscCall(SVDAllocateSolution(svd,0));
     34:   PetscCall(DSAllocate(svd->ds,PetscMax(N,PetscMax(M,P))));
     35:   PetscFunctionReturn(PETSC_SUCCESS);
     36: }

     38: static PetscErrorCode SVDSolve_LAPACK(SVD svd)
     39: {
     40:   PetscInt          M,N,n,i,j,k,ld,lowu,lowv,highu,highv;
     41:   Mat               A,Ar,mat;
     42:   Vec               u,v;
     43:   PetscScalar       *pU,*pV,*pu,*pv,*w;

     45:   PetscFunctionBegin;
     46:   PetscCall(DSGetLeadingDimension(svd->ds,&ld));
     47:   PetscCall(MatCreateRedundantMatrix(svd->OP,0,PETSC_COMM_SELF,MAT_INITIAL_MATRIX,&Ar));
     48:   PetscCall(MatConvert(Ar,MATSEQDENSE,MAT_INITIAL_MATRIX,&mat));
     49:   PetscCall(MatDestroy(&Ar));
     50:   PetscCall(MatGetSize(mat,&M,&N));
     51:   PetscCall(DSSetDimensions(svd->ds,M,0,0));
     52:   PetscCall(DSSVDSetDimensions(svd->ds,N));
     53:   PetscCall(DSGetMat(svd->ds,DS_MAT_A,&A));
     54:   PetscCall(MatCopy(mat,A,SAME_NONZERO_PATTERN));
     55:   PetscCall(DSRestoreMat(svd->ds,DS_MAT_A,&A));
     56:   PetscCall(DSSetState(svd->ds,DS_STATE_RAW));

     58:   n = PetscMin(M,N);
     59:   PetscCall(PetscMalloc1(n,&w));
     60:   PetscCall(DSSolve(svd->ds,w,NULL));
     61:   PetscCall(DSSort(svd->ds,w,NULL,NULL,NULL,NULL));
     62:   PetscCall(DSSynchronize(svd->ds,w,NULL));

     64:   /* copy singular vectors */
     65:   PetscCall(DSGetArray(svd->ds,DS_MAT_U,&pU));
     66:   PetscCall(DSGetArray(svd->ds,DS_MAT_V,&pV));
     67:   for (i=0;i<n;i++) {
     68:     if (svd->which == SVD_SMALLEST) k = n - i - 1;
     69:     else k = i;
     70:     svd->sigma[k] = PetscRealPart(w[i]);
     71:     PetscCall(BVGetColumn(svd->U,k,&u));
     72:     PetscCall(BVGetColumn(svd->V,k,&v));
     73:     PetscCall(VecGetOwnershipRange(u,&lowu,&highu));
     74:     PetscCall(VecGetOwnershipRange(v,&lowv,&highv));
     75:     PetscCall(VecGetArray(u,&pu));
     76:     PetscCall(VecGetArray(v,&pv));
     77:     if (M>=N) {
     78:       for (j=lowu;j<highu;j++) pu[j-lowu] = pU[i*ld+j];
     79:       for (j=lowv;j<highv;j++) pv[j-lowv] = pV[i*ld+j];
     80:     } else {
     81:       for (j=lowu;j<highu;j++) pu[j-lowu] = pV[i*ld+j];
     82:       for (j=lowv;j<highv;j++) pv[j-lowv] = pU[i*ld+j];
     83:     }
     84:     PetscCall(VecRestoreArray(u,&pu));
     85:     PetscCall(VecRestoreArray(v,&pv));
     86:     PetscCall(BVRestoreColumn(svd->U,k,&u));
     87:     PetscCall(BVRestoreColumn(svd->V,k,&v));
     88:   }
     89:   PetscCall(DSRestoreArray(svd->ds,DS_MAT_U,&pU));
     90:   PetscCall(DSRestoreArray(svd->ds,DS_MAT_V,&pV));

     92:   svd->nconv  = n;
     93:   svd->its    = 1;
     94:   svd->reason = SVD_CONVERGED_TOL;

     96:   PetscCall(MatDestroy(&mat));
     97:   PetscCall(PetscFree(w));
     98:   PetscFunctionReturn(PETSC_SUCCESS);
     99: }

    101: static PetscErrorCode SVDSolve_LAPACK_GSVD(SVD svd)
    102: {
    103:   PetscInt          nsv,m,n,p,i,j,mlocal,plocal,ld,lowx,lowu,lowv,highx;
    104:   Mat               Ar,A,Ads,Br,B,Bds;
    105:   Vec               uv,x;
    106:   PetscScalar       *U,*V,*X,*px,*puv,*w;

    108:   PetscFunctionBegin;
    109:   PetscCall(DSGetLeadingDimension(svd->ds,&ld));
    110:   PetscCall(MatCreateRedundantMatrix(svd->OP,0,PETSC_COMM_SELF,MAT_INITIAL_MATRIX,&Ar));
    111:   PetscCall(MatConvert(Ar,MATSEQDENSE,MAT_INITIAL_MATRIX,&A));
    112:   PetscCall(MatDestroy(&Ar));
    113:   PetscCall(MatCreateRedundantMatrix(svd->OPb,0,PETSC_COMM_SELF,MAT_INITIAL_MATRIX,&Br));
    114:   PetscCall(MatConvert(Br,MATSEQDENSE,MAT_INITIAL_MATRIX,&B));
    115:   PetscCall(MatDestroy(&Br));
    116:   PetscCall(MatGetSize(A,&m,&n));
    117:   PetscCall(MatGetLocalSize(svd->OP,&mlocal,NULL));
    118:   PetscCall(MatGetLocalSize(svd->OPb,&plocal,NULL));
    119:   PetscCall(MatGetSize(B,&p,NULL));
    120:   PetscCall(DSSetDimensions(svd->ds,m,0,0));
    121:   PetscCall(DSGSVDSetDimensions(svd->ds,n,p));
    122:   PetscCall(DSGetMat(svd->ds,DS_MAT_A,&Ads));
    123:   PetscCall(MatCopy(A,Ads,SAME_NONZERO_PATTERN));
    124:   PetscCall(DSRestoreMat(svd->ds,DS_MAT_A,&Ads));
    125:   PetscCall(DSGetMat(svd->ds,DS_MAT_B,&Bds));
    126:   PetscCall(MatCopy(B,Bds,SAME_NONZERO_PATTERN));
    127:   PetscCall(DSRestoreMat(svd->ds,DS_MAT_B,&Bds));
    128:   PetscCall(DSSetState(svd->ds,DS_STATE_RAW));

    130:   nsv = PetscMin(n,PetscMin(p,m));
    131:   PetscCall(PetscMalloc1(nsv,&w));
    132:   PetscCall(DSSolve(svd->ds,w,NULL));
    133:   PetscCall(DSSort(svd->ds,w,NULL,NULL,NULL,NULL));
    134:   PetscCall(DSSynchronize(svd->ds,w,NULL));
    135:   PetscCall(DSGetDimensions(svd->ds,NULL,NULL,NULL,&nsv));

    137:   /* copy singular vectors */
    138:   PetscCall(MatGetOwnershipRange(svd->OP,&lowu,NULL));
    139:   PetscCall(MatGetOwnershipRange(svd->OPb,&lowv,NULL));
    140:   PetscCall(DSGetArray(svd->ds,DS_MAT_X,&X));
    141:   PetscCall(DSGetArray(svd->ds,DS_MAT_U,&U));
    142:   PetscCall(DSGetArray(svd->ds,DS_MAT_V,&V));
    143:   for (j=0;j<nsv;j++) {
    144:     svd->sigma[j] = PetscRealPart(w[j]);
    145:     PetscCall(BVGetColumn(svd->V,j,&x));
    146:     PetscCall(VecGetOwnershipRange(x,&lowx,&highx));
    147:     PetscCall(VecGetArrayWrite(x,&px));
    148:     for (i=lowx;i<highx;i++) px[i-lowx] = X[i+j*ld];
    149:     PetscCall(VecRestoreArrayWrite(x,&px));
    150:     PetscCall(BVRestoreColumn(svd->V,j,&x));
    151:     PetscCall(BVGetColumn(svd->U,j,&uv));
    152:     PetscCall(VecGetArrayWrite(uv,&puv));
    153:     for (i=0;i<mlocal;i++) puv[i] = U[i+lowu+j*ld];
    154:     for (i=0;i<plocal;i++) puv[i+mlocal] = V[i+lowv+j*ld];
    155:     PetscCall(VecRestoreArrayWrite(uv,&puv));
    156:     PetscCall(BVRestoreColumn(svd->U,j,&uv));
    157:   }
    158:   PetscCall(DSRestoreArray(svd->ds,DS_MAT_X,&X));
    159:   PetscCall(DSRestoreArray(svd->ds,DS_MAT_U,&U));
    160:   PetscCall(DSRestoreArray(svd->ds,DS_MAT_V,&V));

    162:   svd->nconv  = nsv;
    163:   svd->its    = 1;
    164:   svd->reason = SVD_CONVERGED_TOL;

    166:   PetscCall(MatDestroy(&A));
    167:   PetscCall(MatDestroy(&B));
    168:   PetscCall(PetscFree(w));
    169:   PetscFunctionReturn(PETSC_SUCCESS);
    170: }

    172: static PetscErrorCode SVDSolve_LAPACK_HSVD(SVD svd)
    173: {
    174:   PetscInt          M,N,n,i,j,k,ld,lowu,lowv,highu,highv;
    175:   Mat               A,Ar,mat,D;
    176:   Vec               u,v,vomega;
    177:   PetscScalar       *pU,*pV,*pu,*pv,*w;
    178:   PetscReal         *pD;

    180:   PetscFunctionBegin;
    181:   PetscCall(DSGetLeadingDimension(svd->ds,&ld));
    182:   PetscCall(MatCreateRedundantMatrix(svd->OP,0,PETSC_COMM_SELF,MAT_INITIAL_MATRIX,&Ar));
    183:   PetscCall(MatConvert(Ar,MATSEQDENSE,MAT_INITIAL_MATRIX,&mat));
    184:   PetscCall(MatDestroy(&Ar));
    185:   PetscCall(MatGetSize(mat,&M,&N));
    186:   PetscCall(DSSetDimensions(svd->ds,M,0,0));
    187:   PetscCall(DSHSVDSetDimensions(svd->ds,N));
    188:   PetscCall(DSGetMat(svd->ds,DS_MAT_A,&A));
    189:   PetscCall(MatCopy(mat,A,SAME_NONZERO_PATTERN));
    190:   PetscCall(DSRestoreMat(svd->ds,DS_MAT_A,&A));
    191:   PetscCall(DSGetMatAndColumn(svd->ds,DS_MAT_D,0,&D,&vomega));
    192:   PetscCall(VecCopy(svd->omega,vomega));
    193:   PetscCall(DSRestoreMatAndColumn(svd->ds,DS_MAT_D,0,&D,&vomega));
    194:   PetscCall(DSSetState(svd->ds,DS_STATE_RAW));

    196:   n = PetscMin(M,N);
    197:   PetscCall(PetscMalloc1(n,&w));
    198:   PetscCall(DSSolve(svd->ds,w,NULL));
    199:   PetscCall(DSSort(svd->ds,w,NULL,NULL,NULL,NULL));
    200:   PetscCall(DSSynchronize(svd->ds,w,NULL));

    202:   /* copy singular vectors */
    203:   PetscCall(DSGetArrayReal(svd->ds,DS_MAT_D,&pD));
    204:   PetscCall(DSGetArray(svd->ds,DS_MAT_U,&pU));
    205:   PetscCall(DSGetArray(svd->ds,DS_MAT_V,&pV));
    206:   for (i=0;i<n;i++) {
    207:     if (svd->which == SVD_SMALLEST) k = n - i - 1;
    208:     else k = i;
    209:     svd->sigma[k] = PetscRealPart(w[i]);
    210:     svd->sign[k]  = pD[i];
    211:     PetscCall(BVGetColumn(svd->U,k,&u));
    212:     PetscCall(BVGetColumn(svd->V,k,&v));
    213:     PetscCall(VecGetOwnershipRange(u,&lowu,&highu));
    214:     PetscCall(VecGetOwnershipRange(v,&lowv,&highv));
    215:     PetscCall(VecGetArray(u,&pu));
    216:     PetscCall(VecGetArray(v,&pv));
    217:     if (M>=N) {
    218:       for (j=lowu;j<highu;j++) pu[j-lowu] = pU[i*ld+j];
    219:       for (j=lowv;j<highv;j++) pv[j-lowv] = pV[i*ld+j];
    220:     } else {
    221:       for (j=lowu;j<highu;j++) pu[j-lowu] = pV[i*ld+j];
    222:       for (j=lowv;j<highv;j++) pv[j-lowv] = pU[i*ld+j];
    223:     }
    224:     PetscCall(VecRestoreArray(u,&pu));
    225:     PetscCall(VecRestoreArray(v,&pv));
    226:     PetscCall(BVRestoreColumn(svd->U,k,&u));
    227:     PetscCall(BVRestoreColumn(svd->V,k,&v));
    228:   }
    229:   PetscCall(DSRestoreArrayReal(svd->ds,DS_MAT_D,&pD));
    230:   PetscCall(DSRestoreArray(svd->ds,DS_MAT_U,&pU));
    231:   PetscCall(DSRestoreArray(svd->ds,DS_MAT_V,&pV));

    233:   svd->nconv  = n;
    234:   svd->its    = 1;
    235:   svd->reason = SVD_CONVERGED_TOL;

    237:   PetscCall(MatDestroy(&mat));
    238:   PetscCall(PetscFree(w));
    239:   PetscFunctionReturn(PETSC_SUCCESS);
    240: }

    242: static PetscErrorCode SVDSetDSType_LAPACK(SVD svd)
    243: {
    244:   PetscFunctionBegin;
    245:   PetscCall(DSSetType(svd->ds,svd->OPb?DSGSVD:svd->omega?DSHSVD:DSSVD));
    246:   PetscFunctionReturn(PETSC_SUCCESS);
    247: }

    249: /*MC
    250:    SVDLAPACK - SVDLAPACK = "lapack" - A wrapper to LAPACK singular value solvers.

    252:    Notes:
    253:    This is not really a full-featured singular value solver but simply an interface to
    254:    some LAPACK routines {cite:p}`And99`. These routines operate sequentially
    255:    in dense mode and therefore are suitable only for small size problems.
    256:    This solver should be used only for debugging purposes.

    258:    The LAPACK routine is not called directly, instead a `DS` object of
    259:    the appropriate type is set up.

    261:    Level: beginner

    263: .seealso: [](ch:svd), `SVD`, `SVDType`, `SVDSetType()`, `DS`
    264: M*/
    265: SLEPC_EXTERN PetscErrorCode SVDCreate_LAPACK(SVD svd)
    266: {
    267:   PetscFunctionBegin;
    268:   svd->ops->setup     = SVDSetUp_LAPACK;
    269:   svd->ops->solve     = SVDSolve_LAPACK;
    270:   svd->ops->solveg    = SVDSolve_LAPACK_GSVD;
    271:   svd->ops->solveh    = SVDSolve_LAPACK_HSVD;
    272:   svd->ops->setdstype = SVDSetDSType_LAPACK;
    273:   PetscFunctionReturn(PETSC_SUCCESS);
    274: }