Date: 2022-08-09T09:05:22+00:00

Actual source code: dsgsvd.c
slepc-3.17.2 2022-08-09
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: #include <slepc/private/dsimpl.h>
     11: #include <slepcblaslapack.h>

     13: typedef struct {
     14:   PetscInt m;              /* number of columns */
     15:   PetscInt p;              /* number of rows of B */
     16:   PetscInt tm;             /* number of rows of X after truncating */
     17:   PetscInt tp;             /* number of rows of V after truncating */
     18: } DS_GSVD;

     20: PetscErrorCode DSAllocate_GSVD(DS ds,PetscInt ld)
     21: {
     22:   DSAllocateMat_Private(ds,DS_MAT_A);
     23:   DSAllocateMat_Private(ds,DS_MAT_B);
     24:   DSAllocateMat_Private(ds,DS_MAT_X);
     25:   DSAllocateMat_Private(ds,DS_MAT_U);
     26:   DSAllocateMat_Private(ds,DS_MAT_V);
     27:   DSAllocateMatReal_Private(ds,DS_MAT_T);
     28:   DSAllocateMatReal_Private(ds,DS_MAT_D);
     29:   PetscFree(ds->perm);
     30:   PetscMalloc1(ld,&ds->perm);
     31:   PetscLogObjectMemory((PetscObject)ds,ld*sizeof(PetscInt));
     32:   PetscFunctionReturn(0);
     33: }

     35: /*
     36:   In compact form, A is either in form (a) or (b):

     38:                      (a)                                            (b)
     39:     lower bidiagonal with upper arrow (n=m+1)         square upper bidiagonal with upper arrow (n=m)
     40:      0       l           k                 m-1
     41:     -----------------------------------------         0     l           k                   m-1
     42:     |*                   .                  |        -----------------------------------------
     43:     |  *                 .                  |        |*                 .                    |
     44:     |    *               .                  |        |  *               .                    |
     45:     |      *             .                  |        |    *             .                    |
     46:   l |. . . . o           o                  |      l |. . . o           o                    |
     47:     |          o         o                  |        |        o         o                    |
     48:     |            o       o                  |        |          o       o                    |
     49:     |              o     o                  |        |            o     o                    |
     50:     |                o   o                  |        |              o   o                    |
     51:     |                  o o                  |        |                o o                    |
     52:   k |. . . . . . . . . . o                  |      k |. . . . . . . . . o x                  |
     53:     |                    x x                |        |                    x x                |
     54:     |                      x x              |        |                      x x              |
     55:     |                        x x            |        |                        x x            |
     56:     |                          x x          |        |                          x x          |
     57:     |                            x x        |        |                            x x        |
     58:     |                              x x      |        |                              x x      |
     59:     |                                x x    |        |                                x x    |
     60:     |                                  x x  |        |                                  x x  |
     61:     |                                    x x|        |                                    x x|
     62: n-1 |                                      x|    n-1 |                                      x|
     63:     -----------------------------------------        -----------------------------------------

     65:   and B is square bidiagonal with upper arrow (p=m)

     67:      0       l           k                 m-1
     68:     -----------------------------------------
     69:     |*                   .                  |
     70:     |  *                 .                  |
     71:     |    *               .                  |
     72:     |      *             .                  |
     73:   l |. . . . o           o                  |
     74:     |          o         o                  |
     75:     |            o       o                  |
     76:     |              o     o                  |
     77:     |                o   o                  |
     78:     |                  o o                  |
     79:   k |. . . . . . . . . . o x                |
     80:     |                      x x              |
     81:     |                        x x            |
     82:     |                          x x          |
     83:     |                            x x        |
     84:     |                              x x      |
     85:     |                                x x    |
     86:     |                                  x x  |
     87:     |                                    x x|
     88: p-1 |                                      x|
     89:      ----------------------------------------
     90: */
     91: PetscErrorCode DSView_GSVD(DS ds,PetscViewer viewer)
     92: {
     93:   DS_GSVD           *ctx = (DS_GSVD*)ds->data;
     94:   PetscViewerFormat format;
     95:   PetscInt          i,j,r,k=ds->k,n=ds->n,m=ctx->m,p=ctx->p,rowsa,rowsb,colsa,colsb;
     96:   PetscReal         value;

     98:   PetscViewerGetFormat(viewer,&format);
     99:   if (format == PETSC_VIEWER_ASCII_INFO) PetscFunctionReturn(0);
    100:   if (format == PETSC_VIEWER_ASCII_INFO_DETAIL) {
    101:     PetscViewerASCIIPrintf(viewer,"number of columns: %" PetscInt_FMT "\n",m);
    102:     PetscViewerASCIIPrintf(viewer,"number of rows of B: %" PetscInt_FMT "\n",p);
    103:     PetscFunctionReturn(0);
    104:   }
    106:   if (ds->compact) {
    107:     PetscViewerASCIIUseTabs(viewer,PETSC_FALSE);
    108:     rowsa = n;
    109:     colsa = ds->extrarow? m+1: m;
    110:     rowsb = p;
    111:     colsb = ds->extrarow? m+1: m;
    112:     if (format == PETSC_VIEWER_ASCII_MATLAB) {
    113:       PetscViewerASCIIPrintf(viewer,"%% Size = %" PetscInt_FMT " %" PetscInt_FMT "\n",rowsa,colsa);
    114:       PetscViewerASCIIPrintf(viewer,"zzz = zeros(%" PetscInt_FMT ",3);\n",2*ds->n);
    115:       PetscViewerASCIIPrintf(viewer,"zzz = [\n");
    116:       for (i=0;i<PetscMin(rowsa,colsa);i++) PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT "  %18.16e\n",i+1,i+1,(double)*(ds->rmat[DS_MAT_T]+i));
    117:       for (i=0;i<k;i++) PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT "  %18.16e\n",i+1,k+1,(double)*(ds->rmat[DS_MAT_T]+ds->ld+i));
    118:       if (n>m) { /* A lower bidiagonal */
    119:         for (i=k;i<rowsa-1;i++) PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT "  %18.16e\n",i+2,i+1,(double)*(ds->rmat[DS_MAT_T]+ds->ld+i));
    120:       } else { /* A (square) upper bidiagonal */
    121:         for (i=k;i<colsa-1;i++) PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT "  %18.16e\n",i+1,i+2,(double)*(ds->rmat[DS_MAT_T]+ds->ld+i));
    122:       }
    123:       PetscViewerASCIIPrintf(viewer,"];\n%s = spconvert(zzz);\n",DSMatName[DS_MAT_T]);
    124:       PetscViewerASCIIPrintf(viewer,"%% Size = %" PetscInt_FMT " %" PetscInt_FMT "\n",rowsb,colsb);
    125:       PetscViewerASCIIPrintf(viewer,"zzz = zeros(%" PetscInt_FMT ",3);\n",2*ds->n);
    126:       PetscViewerASCIIPrintf(viewer,"zzz = [\n");
    127:       for (i=0;i<rowsb;i++) PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT "  %18.16e\n",i+1,i+1,(double)*(ds->rmat[DS_MAT_D]+i));
    128:       for (i=0;i<colsb-1;i++) {
    129:         r = PetscMax(i+2,ds->k+1);
    130:         PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT "  %18.16e\n",i+1,r,(double)*(ds->rmat[DS_MAT_T]+2*ds->ld+i));
    131:       }
    132:       PetscViewerASCIIPrintf(viewer,"];\n%s = spconvert(zzz);\n",DSMatName[DS_MAT_D]);
    133:     } else {
    134:       PetscViewerASCIIPrintf(viewer,"Matrix %s =\n",DSMatName[DS_MAT_T]);
    135:       for (i=0;i<rowsa;i++) {
    136:         for (j=0;j<colsa;j++) {
    137:           if (i==j) value = *(ds->rmat[DS_MAT_T]+i);
    138:           else if (i<ds->k && j==ds->k) value = *(ds->rmat[DS_MAT_T]+ds->ld+i);
    139:           else if (n>m && i==j+1 && i>ds->k) value = *(ds->rmat[DS_MAT_T]+ds->ld+j);
    140:           else if (n<=m && i+1==j && i>=ds->k) value = *(ds->rmat[DS_MAT_T]+ds->ld+i);
    141:           else value = 0.0;
    142:           PetscViewerASCIIPrintf(viewer," %18.16e ",(double)value);
    143:         }
    144:         PetscViewerASCIIPrintf(viewer,"\n");
    145:       }
    146:       PetscViewerASCIIPrintf(viewer,"Matrix %s =\n",DSMatName[DS_MAT_D]);
    147:       for (i=0;i<rowsb;i++) {
    148:         for (j=0;j<colsb;j++) {
    149:           if (i==j) value = *(ds->rmat[DS_MAT_D]+i);
    150:           else if (i<ds->k && j==ds->k) value = *(ds->rmat[DS_MAT_T]+2*ds->ld+PetscMin(i,j));
    151:           else if (i+1==j && i>=ds->k) value = *(ds->rmat[DS_MAT_T]+2*ds->ld+i);
    152:           else value = 0.0;
    153:           PetscViewerASCIIPrintf(viewer," %18.16e ",(double)value);
    154:         }
    155:         PetscViewerASCIIPrintf(viewer,"\n");
    156:       }
    157:     }
    158:     PetscViewerASCIIUseTabs(viewer,PETSC_TRUE);
    159:     PetscViewerFlush(viewer);
    160:   } else {
    161:     DSViewMat(ds,viewer,DS_MAT_A);
    162:     DSViewMat(ds,viewer,DS_MAT_B);
    163:   }
    164:   if (ds->state>DS_STATE_INTERMEDIATE) {
    165:     DSViewMat(ds,viewer,DS_MAT_X);
    166:     DSViewMat(ds,viewer,DS_MAT_U);
    167:     DSViewMat(ds,viewer,DS_MAT_V);
    168:   }
    169:   PetscFunctionReturn(0);
    170: }

    172: PetscErrorCode DSVectors_GSVD(DS ds,DSMatType mat,PetscInt *j,PetscReal *rnorm)
    173: {
    174:   switch (mat) {
    175:     case DS_MAT_U:
    176:     case DS_MAT_V:
    177:       if (rnorm) *rnorm = 0.0;
    178:       break;
    179:     case DS_MAT_X:
    180:       break;
    181:     default:
    182:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
    183:   }
    184:   PetscFunctionReturn(0);
    185: }

    187: PetscErrorCode DSSort_GSVD(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
    188: {
    189:   DS_GSVD        *ctx = (DS_GSVD*)ds->data;
    190:   PetscInt       t,l,ld=ds->ld,i,*perm,*perm2;
    191:   PetscReal      *T=NULL,*D=NULL,*eig;
    192:   PetscScalar    *A=NULL,*B=NULL;
    193:   PetscBool      compact=ds->compact;

    195:   if (!ds->sc) PetscFunctionReturn(0);
    197:   l = ds->l;
    198:   t = ds->t;
    199:   perm = ds->perm;
    200:   PetscMalloc2(t,&eig,t,&perm2);
    201:   if (compact) {
    202:     T = ds->rmat[DS_MAT_T];
    203:     D = ds->rmat[DS_MAT_D];
    204:     for (i=0;i<t;i++) eig[i] = (D[i]==0)?PETSC_INFINITY:T[i]/D[i];
    205:   } else {
    206:     A = ds->mat[DS_MAT_A];
    207:     B = ds->mat[DS_MAT_B];
    208:     for (i=0;i<t;i++) eig[i] = (B[i+i*ld]==0)?PETSC_INFINITY:PetscRealPart(A[i+i*ld])/PetscRealPart(B[i*(1+ld)]);
    209:   }
    210:   DSSortEigenvaluesReal_Private(ds,eig,perm);
    211:   PetscArraycpy(perm2,perm,t);
    212:   for (i=l;i<t;i++) wr[i] = eig[perm[i]];
    213:   if (compact) {
    214:     PetscArraycpy(eig,T,t);
    215:     for (i=l;i<t;i++) T[i] = eig[perm[i]];
    216:     PetscArraycpy(eig,D,t);
    217:     for (i=l;i<t;i++) D[i] = eig[perm[i]];
    218:   } else {
    219:     for (i=l;i<t;i++) eig[i] = PetscRealPart(A[i*(1+ld)]);
    220:     for (i=l;i<t;i++) A[i*(1+ld)] = eig[perm[i]];
    221:     for (i=l;i<t;i++) eig[i] = PetscRealPart(B[i*(1+ld)]);
    222:     for (i=l;i<t;i++) B[i*(1+ld)] = eig[perm[i]];
    223:   }
    224:   DSPermuteColumns_Private(ds,l,t,ds->n,DS_MAT_U,perm2);
    225:   PetscArraycpy(perm2,perm,t);
    226:   DSPermuteColumns_Private(ds,l,t,ctx->m,DS_MAT_X,perm2);
    227:   DSPermuteColumns_Private(ds,l,t,ctx->p,DS_MAT_V,perm);
    228:   PetscFree2(eig,perm2);
    229:   PetscFunctionReturn(0);
    230: }

    232: PetscErrorCode DSUpdateExtraRow_GSVD(DS ds)
    233: {
    234:   DS_GSVD        *ctx = (DS_GSVD*)ds->data;
    235:   PetscInt       i;
    236:   PetscBLASInt   n=0,m=0,ld=0;
    237:   PetscScalar    *U,*V;
    238:   PetscReal      *T,*e,*f,alpha,beta,betah;

    241:   PetscBLASIntCast(ds->n,&n);
    242:   PetscBLASIntCast(ctx->m,&m);
    243:   PetscBLASIntCast(ds->ld,&ld);
    244:   U = ds->mat[DS_MAT_U];
    245:   V = ds->mat[DS_MAT_V];
    246:   T = ds->rmat[DS_MAT_T];
    247:   e = ds->rmat[DS_MAT_T]+ld;
    248:   f = ds->rmat[DS_MAT_T]+2*ld;

    250:   if (ds->compact) {
    251:     if (n<=m) {   /* upper variant, A is square upper bidiagonal */
    252:       beta  = e[m-1];   /* in compact, we assume all entries are zero except the last one */
    253:       betah = f[m-1];
    254:       for (i=0;i<m;i++) {
    255:         e[i] = PetscRealPart(beta*U[m-1+i*ld]);
    256:         f[i] = PetscRealPart(betah*V[m-1+i*ld]);
    257:       }
    258:     } else {   /* lower variant, A is (m+1)xm lower bidiagonal */
    259:       alpha = T[m];
    260:       betah = f[m-1];
    261:       for (i=0;i<m;i++) {
    262:         e[i] = PetscRealPart(alpha*U[m+i*ld]);
    263:         f[i] = PetscRealPart(betah*V[m-1+i*ld]);
    264:       }
    265:       T[m] = PetscRealPart(alpha*U[m+m*ld]);
    266:     }
    267:     ds->k = m;
    268:   } else SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_SUP,"Not implemented for non-compact storage");
    269:   PetscFunctionReturn(0);
    270: }

    272: PetscErrorCode DSTruncate_GSVD(DS ds,PetscInt n,PetscBool trim)
    273: {
    274:   DS_GSVD     *ctx = (DS_GSVD*)ds->data;
    275:   PetscScalar *U = ds->mat[DS_MAT_U];
    276:   PetscReal   *T = ds->rmat[DS_MAT_T];
    277:   PetscInt    i,m=ctx->m,ld=ds->ld;
    278:   PetscBool   lower=(ds->n>ctx->m)?PETSC_TRUE:PETSC_FALSE;

    281:   if (trim) {
    282:     ds->l   = 0;
    283:     ds->k   = 0;
    284:     ds->n   = lower? n+1: n;
    285:     ctx->m  = n;
    286:     ctx->p  = n;
    287:     ds->t   = ds->n;   /* truncated length equal to the new dimension */
    288:     ctx->tm = ctx->m;  /* must also keep the previous dimension of X */
    289:     ctx->tp = ctx->p;  /* must also keep the previous dimension of V */
    290:   } else {
    291:     if (lower) {
    292:       /* move value of diagonal element of arrow (alpha) */
    293:       T[n] = T[m];
    294:       /* copy last column of U so that it updates the next initial vector of U1 */
    295:       for (i=0;i<=m;i++) U[i+n*ld] = U[i+m*ld];
    296:     }
    297:     ds->k   = (ds->extrarow)? n: 0;
    298:     ds->t   = ds->n;   /* truncated length equal to previous dimension */
    299:     ctx->tm = ctx->m;  /* must also keep the previous dimension of X */
    300:     ctx->tp = ctx->p;  /* must also keep the previous dimension of V */
    301:     ds->n   = lower? n+1: n;
    302:     ctx->m  = n;
    303:     ctx->p  = n;
    304:   }
    305:   PetscFunctionReturn(0);
    306: }

    308: static PetscErrorCode DSSwitchFormat_GSVD(DS ds)
    309: {
    310:   DS_GSVD        *ctx = (DS_GSVD*)ds->data;
    311:   PetscReal      *T = ds->rmat[DS_MAT_T];
    312:   PetscReal      *D = ds->rmat[DS_MAT_D];
    313:   PetscScalar    *A = ds->mat[DS_MAT_A];
    314:   PetscScalar    *B = ds->mat[DS_MAT_B];
    315:   PetscInt       i,n=ds->n,k=ds->k,ld=ds->ld,m=ctx->m;

    318:   /* switch from compact (arrow) to dense storage */
    319:   /* bidiagonal associated to B is stored in D and T+2*ld */
    320:   PetscArrayzero(A,ld*ld);
    321:   PetscArrayzero(B,ld*ld);
    322:   for (i=0;i<k;i++) {
    323:     A[i+i*ld] = T[i];
    324:     A[i+k*ld] = T[i+ld];
    325:     B[i+i*ld] = D[i];
    326:     B[i+k*ld] = T[i+2*ld];
    327:   }
    328:   /* B is upper bidiagonal */
    329:   B[k+k*ld] = D[k];
    330:   for (i=k+1;i<m;i++) {
    331:     B[i+i*ld]   = D[i];
    332:     B[i-1+i*ld] = T[i-1+2*ld];
    333:   }
    334:   /* A can be upper (square) or lower bidiagonal */
    335:   for (i=k;i<m;i++) A[i+i*ld] = T[i];
    336:   if (n>m) for (i=k;i<m;i++) A[i+1+i*ld] = T[i+ld];
    337:   else for (i=k+1;i<m;i++) A[i-1+i*ld] = T[i-1+ld];
    338:   PetscFunctionReturn(0);
    339: }

    341: /*
    342:   Compact format is used when [A;B] has orthonormal columns.
    343:   In this case R=I and the GSVD of (A,B) is the CS decomposition
    344: */
    345: PetscErrorCode DSSolve_GSVD(DS ds,PetscScalar *wr,PetscScalar *wi)
    346: {
    347:   DS_GSVD        *ctx = (DS_GSVD*)ds->data;
    348:   PetscInt       i,j;
    349:   PetscBLASInt   n1,m1,info,lc = 0,n = 0,m = 0,p = 0,p1,l,k,q,ld,off,lwork,r;
    350:   PetscScalar    *A,*B,*X,*U,*V,sone=1.0,smone=-1.0;
    351:   PetscReal      *alpha,*beta,*T,*D;
    352: #if !defined(SLEPC_MISSING_LAPACK_GGSVD3)
    353:   PetscScalar    a,dummy;
    354:   PetscReal      rdummy;
    355:   PetscBLASInt   idummy;
    356: #endif

    359:   PetscBLASIntCast(ds->n,&m);
    360:   PetscBLASIntCast(ctx->m,&n);
    361:   PetscBLASIntCast(ctx->p,&p);
    362:   PetscBLASIntCast(ds->l,&lc);
    363:   /* In compact storage B is always nxn and A can be either nxn or (n+1)xn */
    364:   if (!ds->compact) {
    367:   PetscBLASIntCast(ds->ld,&ld);
    368:   n1 = n-lc;     /* n1 = size of leading block, excl. locked + size of trailing block */
    369:   m1 = m-lc;
    370:   p1 = p-lc;
    371:   off = lc+lc*ld;
    372:   A = ds->mat[DS_MAT_A];
    373:   B = ds->mat[DS_MAT_B];
    374:   X = ds->mat[DS_MAT_X];
    375:   U = ds->mat[DS_MAT_U];
    376:   V = ds->mat[DS_MAT_V];
    377:   PetscArrayzero(X,ld*ld);
    378:   for (i=0;i<lc;i++) X[i+i*ld] = 1.0;
    379:   PetscArrayzero(U,ld*ld);
    380:   for (i=0;i<lc;i++) U[i+i*ld] = 1.0;
    381:   PetscArrayzero(V,ld*ld);
    382:   for (i=0;i<lc;i++) V[i+i*ld] = 1.0;
    383:   if (ds->compact) DSSwitchFormat_GSVD(ds);
    384:   T = ds->rmat[DS_MAT_T];
    385:   D = ds->rmat[DS_MAT_D];

    387: #if !defined(SLEPC_MISSING_LAPACK_GGSVD3)
    388:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    389:   /* workspace query and memory allocation */
    390:   lwork = -1;
    391: #if !defined (PETSC_USE_COMPLEX)
    392:   PetscStackCallBLAS("LAPACKggsvd3",LAPACKggsvd3_("U","V","Q",&m1,&n1,&p1,&k,&l,&dummy,&ld,&dummy,&ld,&rdummy,&rdummy,&dummy,&ld,&dummy,&ld,&dummy,&ld,&a,&lwork,&idummy,&info));
    393:   PetscBLASIntCast((PetscInt)a,&lwork);
    394: #else
    395:   PetscStackCallBLAS("LAPACKggsvd3",LAPACKggsvd3_("U","V","Q",&m1,&n1,&p1,&k,&l,&dummy,&ld,&dummy,&ld,&rdummy,&rdummy,&dummy,&ld,&dummy,&ld,&dummy,&ld,&a,&lwork,&rdummy,&idummy,&info));
    396:   PetscBLASIntCast((PetscInt)PetscRealPart(a),&lwork);
    397: #endif

    399: #if !defined (PETSC_USE_COMPLEX)
    400:   DSAllocateWork_Private(ds,lwork,2*ds->ld,ds->ld);
    401:   alpha = ds->rwork;
    402:   beta  = ds->rwork+ds->ld;
    403:   PetscStackCallBLAS("LAPACKggsvd3",LAPACKggsvd3_("U","V","Q",&m1,&n1,&p1,&k,&l,A+off,&ld,B+off,&ld,alpha,beta,U+off,&ld,V+off,&ld,X+off,&ld,ds->work,&lwork,ds->iwork,&info));
    404: #else
    405:   DSAllocateWork_Private(ds,lwork,4*ds->ld,ds->ld);
    406:   alpha = ds->rwork+2*ds->ld;
    407:   beta  = ds->rwork+3*ds->ld;
    408:   PetscStackCallBLAS("LAPACKggsvd3",LAPACKggsvd3_("U","V","Q",&m1,&n1,&p1,&k,&l,A+off,&ld,B+off,&ld,alpha,beta,U+off,&ld,V+off,&ld,X+off,&ld,ds->work,&lwork,ds->rwork,ds->iwork,&info));
    409: #endif
    410:   PetscFPTrapPop();
    411:   SlepcCheckLapackInfo("ggsvd3",info);

    413: #else  // defined(SLEPC_MISSING_LAPACK_GGSVD3)

    415:   lwork = PetscMax(PetscMax(3*n,m),p)+n;
    416:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    417: #if !defined (PETSC_USE_COMPLEX)
    418:   DSAllocateWork_Private(ds,lwork,2*ds->ld,ds->ld);
    419:   alpha = ds->rwork;
    420:   beta  = ds->rwork+ds->ld;
    421:   PetscStackCallBLAS("LAPACKggsvd",LAPACKggsvd_("U","V","Q",&m1,&n1,&p1,&k,&l,A+off,&ld,B+off,&ld,alpha,beta,U+off,&ld,V+off,&ld,X+off,&ld,ds->work,ds->iwork,&info));
    422: #else
    423:   DSAllocateWork_Private(ds,lwork,4*ds->ld,ds->ld);
    424:   alpha = ds->rwork+2*ds->ld;
    425:   beta  = ds->rwork+3*ds->ld;
    426:   PetscStackCallBLAS("LAPACKggsvd",LAPACKggsvd_("U","V","Q",&m1,&n1,&p1,&k,&l,A+off,&ld,B+off,&ld,alpha,beta,U+off,&ld,V+off,&ld,X+off,&ld,ds->work,ds->rwork,ds->iwork,&info));
    427: #endif
    428:   PetscFPTrapPop();
    429:   SlepcCheckLapackInfo("ggsvd",info);

    431: #endif

    434:   if (ds->compact) {
    435:     /* R is the identity matrix (except the sign) */
    436:     for (i=lc;i<n;i++) {
    437:       if (PetscRealPart(A[i+i*ld])<0.0) { /* scale column i */
    438:         for (j=lc;j<n;j++) X[j+i*ld] = -X[j+i*ld];
    439:       }
    440:     }
    441:     PetscArrayzero(T+ld,m-1);
    442:     PetscArrayzero(T+2*ld,n-1);
    443:     for (i=lc;i<n;i++) {
    444:       T[i] = alpha[i-lc];
    445:       D[i] = beta[i-lc];
    446:       if (D[i]==0.0) wr[i] = PETSC_INFINITY;
    447:       else wr[i] = T[i]/D[i];
    448:     }
    449:     ds->t = n;
    450:   } else {
    451:     /* X = X*inv(R) */
    452:     q = PetscMin(m,n);
    453:     PetscStackCallBLAS("BLAStrsm",BLAStrsm_("R","U","N","N",&n,&q,&sone,A,&ld,X,&ld));
    454:     if (m<n) {
    455:       r = n-m;
    456:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&r,&m,&sone,X,&ld,A,&ld,&smone,X+m*ld,&ld));
    457:       PetscStackCallBLAS("BLAStrsm",BLAStrsm_("R","U","N","N",&n,&r,&sone,B+m*ld,&ld,X+m*ld,&ld));
    458:     }
    459:     if (k>0) {
    460:       for (i=k;i<PetscMin(m,k+l);i++) {
    461:         PetscArraycpy(X+(i-k)*ld,X+i*ld,ld);
    462:         PetscArraycpy(U+(i-k)*ld,U+i*ld,ld);
    463:       }
    464:     }
    465:     /* singular values */
    466:     PetscArrayzero(A,ld*ld);
    467:     PetscArrayzero(B,ld*ld);
    468:     for (j=k;j<PetscMin(m,k+l);j++) {
    469:       A[(j-k)*(1+ld)] = alpha[j];
    470:       B[(j-k)*(1+ld)] = beta[j];
    471:       wr[j-k] = alpha[j]/beta[j];
    472:     }
    473:     ds->t = PetscMin(m,k+l)-k; /* set number of computed values */
    474:   }
    475:   PetscFunctionReturn(0);
    476: }

    478: PetscErrorCode DSSynchronize_GSVD(DS ds,PetscScalar eigr[],PetscScalar eigi[])
    479: {
    480:   DS_GSVD        *ctx = (DS_GSVD*)ds->data;
    481:   PetscInt       ld=ds->ld,l=ds->l,k=0,kr=0;
    482:   PetscMPIInt    m=ctx->m,rank,off=0,size,n,ldn,ld3;

    484:   if (ds->compact) kr = 3*ld;
    485:   else k = 2*(m-l)*ld;
    486:   if (ds->state>DS_STATE_RAW) k += 3*(m-l)*ld;
    487:   if (eigr) k += m-l;
    488:   DSAllocateWork_Private(ds,k+kr,0,0);
    489:   PetscMPIIntCast(k*sizeof(PetscScalar)+kr*sizeof(PetscReal),&size);
    490:   PetscMPIIntCast(m-l,&n);
    491:   PetscMPIIntCast(ld*(m-l),&ldn);
    492:   PetscMPIIntCast(3*ld,&ld3);
    493:   MPI_Comm_rank(PetscObjectComm((PetscObject)ds),&rank);
    494:   if (!rank) {
    495:     if (ds->compact) MPI_Pack(ds->rmat[DS_MAT_T],ld3,MPIU_REAL,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
    496:     else MPI_Pack(ds->mat[DS_MAT_A]+l*ld,ldn,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
    497:     if (ds->state>DS_STATE_RAW) {
    498:       MPI_Pack(ds->mat[DS_MAT_U]+l*ld,ldn,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
    499:       MPI_Pack(ds->mat[DS_MAT_V]+l*ld,ldn,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
    500:       MPI_Pack(ds->mat[DS_MAT_X]+l*ld,ldn,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
    501:     }
    502:     if (eigr) MPI_Pack(eigr+l,n,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
    503:   }
    504:   MPI_Bcast(ds->work,size,MPI_BYTE,0,PetscObjectComm((PetscObject)ds));
    505:   if (rank) {
    506:     if (ds->compact) MPI_Unpack(ds->work,size,&off,ds->rmat[DS_MAT_T],ld3,MPIU_REAL,PetscObjectComm((PetscObject)ds));
    507:     else MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_A]+l*ld,ldn,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
    508:     if (ds->state>DS_STATE_RAW) {
    509:       MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_U]+l*ld,ldn,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
    510:       MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_V]+l*ld,ldn,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
    511:       MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_X]+l*ld,ldn,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
    512:     }
    513:     if (eigr) MPI_Unpack(ds->work,size,&off,eigr+l,n,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
    514:   }
    515:   PetscFunctionReturn(0);
    516: }

    518: PetscErrorCode DSMatGetSize_GSVD(DS ds,DSMatType t,PetscInt *rows,PetscInt *cols)
    519: {
    520:   DS_GSVD *ctx = (DS_GSVD*)ds->data;

    523:   switch (t) {
    524:     case DS_MAT_A:
    525:       *rows = ds->n;
    526:       *cols = ds->extrarow? ctx->m+1: ctx->m;
    527:       break;
    528:     case DS_MAT_B:
    529:       *rows = ctx->p;
    530:       *cols = ds->extrarow? ctx->m+1: ctx->m;
    531:       break;
    532:     case DS_MAT_U:
    533:       *rows = ds->state==DS_STATE_TRUNCATED? ds->t: ds->n;
    534:       *cols = ds->n;
    535:       break;
    536:     case DS_MAT_V:
    537:       *rows = ds->state==DS_STATE_TRUNCATED? ctx->tp: ctx->p;
    538:       *cols = ctx->p;
    539:       break;
    540:     case DS_MAT_X:
    541:       *rows = ds->state==DS_STATE_TRUNCATED? ctx->tm: ctx->m;
    542:       *cols = ctx->m;
    543:       break;
    544:     default:
    545:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid t parameter");
    546:   }
    547:   PetscFunctionReturn(0);
    548: }

    550: static PetscErrorCode DSGSVDSetDimensions_GSVD(DS ds,PetscInt m,PetscInt p)
    551: {
    552:   DS_GSVD *ctx = (DS_GSVD*)ds->data;

    554:   DSCheckAlloc(ds,1);
    555:   if (m==PETSC_DECIDE || m==PETSC_DEFAULT) {
    556:     ctx->m = ds->ld;
    557:   } else {
    559:     ctx->m = m;
    560:   }
    561:   if (p==PETSC_DECIDE || p==PETSC_DEFAULT) {
    562:     ctx->p = ds->n;
    563:   } else {
    565:     ctx->p = p;
    566:   }
    567:   PetscFunctionReturn(0);
    568: }

    570: /*@
    571:    DSGSVDSetDimensions - Sets the number of columns and rows for a DSGSVD.

    573:    Logically Collective on ds

    575:    Input Parameters:
    576: +  ds - the direct solver context
    577: .  m  - the number of columns
    578: -  p  - the number of rows for the second matrix (B)

    580:    Notes:
    581:    This call is complementary to DSSetDimensions(), to provide two dimensions
    582:    that are specific to this DS type. The number of rows for the first matrix (A)
    583:    is set by DSSetDimensions().

    585:    Level: intermediate

    587: .seealso: DSGSVDGetDimensions(), DSSetDimensions()
    588: @*/
    589: PetscErrorCode DSGSVDSetDimensions(DS ds,PetscInt m,PetscInt p)
    590: {
    594:   PetscTryMethod(ds,"DSGSVDSetDimensions_C",(DS,PetscInt,PetscInt),(ds,m,p));
    595:   PetscFunctionReturn(0);
    596: }

    598: static PetscErrorCode DSGSVDGetDimensions_GSVD(DS ds,PetscInt *m,PetscInt *p)
    599: {
    600:   DS_GSVD *ctx = (DS_GSVD*)ds->data;

    602:   if (m) *m = ctx->m;
    603:   if (p) *p = ctx->p;
    604:   PetscFunctionReturn(0);
    605: }

    607: /*@
    608:    DSGSVDGetDimensions - Returns the number of columns and rows for a DSGSVD.

    610:    Not collective

    612:    Input Parameter:
    613: .  ds - the direct solver context

    615:    Output Parameters:
    616: +  m - the number of columns
    617: -  p - the number of rows for the second matrix (B)

    619:    Level: intermediate

    621: .seealso: DSGSVDSetDimensions()
    622: @*/
    623: PetscErrorCode DSGSVDGetDimensions(DS ds,PetscInt *m,PetscInt *p)
    624: {
    626:   PetscUseMethod(ds,"DSGSVDGetDimensions_C",(DS,PetscInt*,PetscInt*),(ds,m,p));
    627:   PetscFunctionReturn(0);
    628: }

    630: PetscErrorCode DSDestroy_GSVD(DS ds)
    631: {
    632:   PetscFree(ds->data);
    633:   PetscObjectComposeFunction((PetscObject)ds,"DSGSVDSetDimensions_C",NULL);
    634:   PetscObjectComposeFunction((PetscObject)ds,"DSGSVDGetDimensions_C",NULL);
    635:   PetscFunctionReturn(0);
    636: }

    638: /*MC
    639:    DSGSVD - Dense Generalized Singular Value Decomposition.

    641:    Level: beginner

    643:    Notes:
    644:    The problem is expressed as A*X = U*C, B*X = V*S, where A and B are
    645:    matrices with the same number of columns, m, U and V are orthogonal
    646:    (unitary), and X is an mxm invertible matrix. The DS object does not
    647:    expose matrices C and S, instead the singular values sigma, which are
    648:    the ratios c_i/s_i, are returned in the arguments of DSSolve().
    649:    Note that the number of columns of the returned X, U, V may be smaller
    650:    in the case that some c_i or s_i are zero.

    652:    The number of rows of A (and U) is the value n passed with DSSetDimensions().
    653:    The number of columns m and the number of rows of B (and V) must be
    654:    set via DSGSVDSetDimensions().

    656:    Internally, LAPACK's representation is used, U'*A*Q = C*[0 R], V'*B*Q = S*[0 R],
    657:    where X = Q*inv(R) is computed at the end of DSSolve().

    659:    If the compact storage format is selected, then a simplified problem is
    660:    solved, where A and B are bidiagonal (possibly with an arrow), and [A;B]
    661:    is assumed to have orthonormal columns. We consider two cases: (1) A and B
    662:    are square mxm upper bidiagonal, and (2) A is lower bidiagonal with m+1
    663:    rows and B is square upper bidiagonal. In these cases, R=I so it
    664:    corresponds to the CS decomposition. The first matrix is stored in two
    665:    diagonals of DS_MAT_T, while the second matrix is stored in DS_MAT_D
    666:    and the remaining diagonal of DS_MAT_T.

    668:    Allowed arguments of DSVectors() are DS_MAT_U, DS_MAT_V and DS_MAT_X.

    670:    Used DS matrices:
    671: +  DS_MAT_A - first problem matrix
    672: .  DS_MAT_B - second problem matrix
    673: .  DS_MAT_T - first upper bidiagonal matrix (if compact storage is selected)
    674: -  DS_MAT_D - second upper bidiagonal matrix (if compact storage is selected)

    676:    Implemented methods:
    677: .  0 - Lapack (_ggsvd3 if available, or _ggsvd)

    679: .seealso: DSCreate(), DSSetType(), DSType, DSGSVDSetDimensions()
    680: M*/
    681: SLEPC_EXTERN PetscErrorCode DSCreate_GSVD(DS ds)
    682: {
    683:   DS_GSVD        *ctx;

    685:   PetscNewLog(ds,&ctx);
    686:   ds->data = (void*)ctx;

    688:   ds->ops->allocate      = DSAllocate_GSVD;
    689:   ds->ops->view          = DSView_GSVD;
    690:   ds->ops->vectors       = DSVectors_GSVD;
    691:   ds->ops->sort          = DSSort_GSVD;
    692:   ds->ops->solve[0]      = DSSolve_GSVD;
    693:   ds->ops->synchronize   = DSSynchronize_GSVD;
    694:   ds->ops->truncate      = DSTruncate_GSVD;
    695:   ds->ops->update        = DSUpdateExtraRow_GSVD;
    696:   ds->ops->matgetsize    = DSMatGetSize_GSVD;
    697:   ds->ops->destroy       = DSDestroy_GSVD;
    698:   PetscObjectComposeFunction((PetscObject)ds,"DSGSVDSetDimensions_C",DSGSVDSetDimensions_GSVD);
    699:   PetscObjectComposeFunction((PetscObject)ds,"DSGSVDGetDimensions_C",DSGSVDGetDimensions_GSVD);
    700:   PetscFunctionReturn(0);
    701: }