Date: 2022-11-02T11:46:10+00:00

Actual source code: dspriv.c
slepc-3.18.1 2022-11-02
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:    Private DS routines
     12: */

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

     17: PetscErrorCode DSAllocateMat_Private(DS ds,DSMatType m)
     18: {
     19:   PetscInt       n,d,rows=0,cols;
     20:   PetscBool      ispep,isnep;

     22:   n = ds->ld;
     23:   PetscObjectTypeCompare((PetscObject)ds,DSPEP,&ispep);
     24:   if (ispep) {
     25:     if (m==DS_MAT_A || m==DS_MAT_B || m==DS_MAT_W || m==DS_MAT_U || m==DS_MAT_X || m==DS_MAT_Y) {
     26:       DSPEPGetDegree(ds,&d);
     27:       n = d*ds->ld;
     28:     }
     29:   } else {
     30:     PetscObjectTypeCompare((PetscObject)ds,DSNEP,&isnep);
     31:     if (isnep) {
     32:       if (m==DS_MAT_Q || m==DS_MAT_Z || m==DS_MAT_U || m==DS_MAT_V || m==DS_MAT_X || m==DS_MAT_Y) {
     33:         DSNEPGetMinimality(ds,&d);
     34:         n = d*ds->ld;
     35:       }
     36:     }
     37:   }
     38:   cols = n;

     40:   switch (m) {
     41:     case DS_MAT_T:
     42:       cols = PetscDefined(USE_COMPLEX)? 2: 3;
     43:       rows = n;
     44:       break;
     45:     case DS_MAT_D:
     46:       cols = 1;
     47:       rows = n;
     48:       break;
     49:     case DS_MAT_X:
     50:       rows = ds->ld;
     51:       break;
     52:     case DS_MAT_Y:
     53:       rows = ds->ld;
     54:       break;
     55:     default:
     56:       rows = n;
     57:   }
     58:   if (ds->omat[m]) MatZeroEntries(ds->omat[m]);
     59:   else {
     60:     MatCreateSeqDense(PETSC_COMM_SELF,rows,cols,NULL,&ds->omat[m]);
     61:   }
     62:   return 0;
     63: }

     65: PetscErrorCode DSAllocateWork_Private(DS ds,PetscInt s,PetscInt r,PetscInt i)
     66: {
     67:   if (s>ds->lwork) {
     68:     PetscFree(ds->work);
     69:     PetscMalloc1(s,&ds->work);
     70:     ds->lwork = s;
     71:   }
     72:   if (r>ds->lrwork) {
     73:     PetscFree(ds->rwork);
     74:     PetscMalloc1(r,&ds->rwork);
     75:     ds->lrwork = r;
     76:   }
     77:   if (i>ds->liwork) {
     78:     PetscFree(ds->iwork);
     79:     PetscMalloc1(i,&ds->iwork);
     80:     ds->liwork = i;
     81:   }
     82:   return 0;
     83: }

     85: /*@C
     86:    DSViewMat - Prints one of the internal DS matrices.

     88:    Collective on ds

     90:    Input Parameters:
     91: +  ds     - the direct solver context
     92: .  viewer - visualization context
     93: -  m      - matrix to display

     95:    Note:
     96:    Works only for ascii viewers. Set the viewer in Matlab format if
     97:    want to paste into Matlab.

     99:    Level: developer

    101: .seealso: DSView()
    102: @*/
    103: PetscErrorCode DSViewMat(DS ds,PetscViewer viewer,DSMatType m)
    104: {
    105:   PetscInt          i,j,rows,cols;
    106:   const PetscScalar *M=NULL,*v;
    107:   PetscViewerFormat format;
    108: #if defined(PETSC_USE_COMPLEX)
    109:   PetscBool         allreal = PETSC_TRUE;
    110:   const PetscReal   *vr;
    111: #endif

    115:   DSCheckValidMat(ds,m,3);
    116:   if (!viewer) PetscViewerASCIIGetStdout(PetscObjectComm((PetscObject)ds),&viewer);
    119:   PetscViewerGetFormat(viewer,&format);
    120:   if (format == PETSC_VIEWER_ASCII_INFO || format == PETSC_VIEWER_ASCII_INFO_DETAIL) return 0;
    121:   PetscViewerASCIIUseTabs(viewer,PETSC_FALSE);
    122:   DSMatGetSize(ds,m,&rows,&cols);
    123:   MatDenseGetArrayRead(ds->omat[m],&M);
    124: #if defined(PETSC_USE_COMPLEX)
    125:   /* determine if matrix has all real values */
    126:   if (m!=DS_MAT_T && m!=DS_MAT_D) {
    127:     /* determine if matrix has all real values */
    128:     v = M;
    129:     for (i=0;i<rows;i++)
    130:       for (j=0;j<cols;j++)
    131:         if (PetscImaginaryPart(v[i+j*ds->ld])) { allreal = PETSC_FALSE; break; }
    132:   }
    133:   if (m==DS_MAT_T) cols=3;
    134: #endif
    135:   if (format == PETSC_VIEWER_ASCII_MATLAB) {
    136:     PetscViewerASCIIPrintf(viewer,"%% Size = %" PetscInt_FMT " %" PetscInt_FMT "\n",rows,cols);
    137:     PetscViewerASCIIPrintf(viewer,"%s = [\n",DSMatName[m]);
    138:   } else PetscViewerASCIIPrintf(viewer,"Matrix %s =\n",DSMatName[m]);

    140:   for (i=0;i<rows;i++) {
    141:     v = M+i;
    142: #if defined(PETSC_USE_COMPLEX)
    143:     vr = (const PetscReal*)M+i;   /* handle compact storage, 2nd column is in imaginary part of 1st column */
    144: #endif
    145:     for (j=0;j<cols;j++) {
    146: #if defined(PETSC_USE_COMPLEX)
    147:       if (m!=DS_MAT_T && m!=DS_MAT_D) {
    148:         if (allreal) PetscViewerASCIIPrintf(viewer,"%18.16e ",(double)PetscRealPart(*v));
    149:         else PetscViewerASCIIPrintf(viewer,"%18.16e%+18.16ei ",(double)PetscRealPart(*v),(double)PetscImaginaryPart(*v));
    150:       } else PetscViewerASCIIPrintf(viewer,"%18.16e ",(double)*vr);
    151: #else
    152:       PetscViewerASCIIPrintf(viewer,"%18.16e ",(double)*v);
    153: #endif
    154:       v += ds->ld;
    155: #if defined(PETSC_USE_COMPLEX)
    156:       if (m==DS_MAT_T) vr += ds->ld;
    157: #endif
    158:     }
    159:     PetscViewerASCIIPrintf(viewer,"\n");
    160:   }
    161:   MatDenseRestoreArrayRead(ds->omat[m],&M);

    163:   if (format == PETSC_VIEWER_ASCII_MATLAB) PetscViewerASCIIPrintf(viewer,"];\n");
    164:   PetscViewerASCIIUseTabs(viewer,PETSC_TRUE);
    165:   PetscViewerFlush(viewer);
    166:   return 0;
    167: }

    169: PetscErrorCode DSSortEigenvalues_Private(DS ds,PetscScalar *wr,PetscScalar *wi,PetscInt *perm,PetscBool isghiep)
    170: {
    171:   PetscScalar    re,im,wi0;
    172:   PetscInt       n,i,j,result,tmp1,tmp2=0,d=1;

    174:   n = ds->t;   /* sort only first t pairs if truncated */
    175:   /* insertion sort */
    176:   i=ds->l+1;
    177: #if !defined(PETSC_USE_COMPLEX)
    178:   if (wi && wi[perm[i-1]]!=0.0) i++; /* initial value is complex */
    179: #else
    180:   if (isghiep && PetscImaginaryPart(wr[perm[i-1]])!=0.0) i++;
    181: #endif
    182:   for (;i<n;i+=d) {
    183:     re = wr[perm[i]];
    184:     if (wi) im = wi[perm[i]];
    185:     else im = 0.0;
    186:     tmp1 = perm[i];
    187: #if !defined(PETSC_USE_COMPLEX)
    188:     if (im!=0.0) { d = 2; tmp2 = perm[i+1]; }
    189:     else d = 1;
    190: #else
    191:     if (isghiep && PetscImaginaryPart(re)!=0.0) { d = 2; tmp2 = perm[i+1]; }
    192:     else d = 1;
    193: #endif
    194:     j = i-1;
    195:     if (wi) wi0 = wi[perm[j]];
    196:     else wi0 = 0.0;
    197:     SlepcSCCompare(ds->sc,re,im,wr[perm[j]],wi0,&result);
    198:     while (result<0 && j>=ds->l) {
    199:       perm[j+d] = perm[j];
    200:       j--;
    201: #if !defined(PETSC_USE_COMPLEX)
    202:       if (wi && wi[perm[j+1]]!=0)
    203: #else
    204:       if (isghiep && PetscImaginaryPart(wr[perm[j+1]])!=0)
    205: #endif
    206:         { perm[j+d] = perm[j]; j--; }

    208:       if (j>=ds->l) {
    209:         if (wi) wi0 = wi[perm[j]];
    210:         else wi0 = 0.0;
    211:         SlepcSCCompare(ds->sc,re,im,wr[perm[j]],wi0,&result);
    212:       }
    213:     }
    214:     perm[j+1] = tmp1;
    215:     if (d==2) perm[j+2] = tmp2;
    216:   }
    217:   return 0;
    218: }

    220: PetscErrorCode DSSortEigenvaluesReal_Private(DS ds,PetscReal *eig,PetscInt *perm)
    221: {
    222:   PetscScalar    re;
    223:   PetscInt       i,j,result,tmp,l,n;

    225:   n = ds->t;   /* sort only first t pairs if truncated */
    226:   l = ds->l;
    227:   /* insertion sort */
    228:   for (i=l+1;i<n;i++) {
    229:     re = eig[perm[i]];
    230:     j = i-1;
    231:     SlepcSCCompare(ds->sc,re,0.0,eig[perm[j]],0.0,&result);
    232:     while (result<0 && j>=l) {
    233:       tmp = perm[j]; perm[j] = perm[j+1]; perm[j+1] = tmp; j--;
    234:       if (j>=l) SlepcSCCompare(ds->sc,re,0.0,eig[perm[j]],0.0,&result);
    235:     }
    236:   }
    237:   return 0;
    238: }

    240: /*
    241:   Permute comumns [istart..iend-1] of [mat] according to perm. Columns have length n
    242:  */
    243: PetscErrorCode DSPermuteColumns_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt n,DSMatType mat,PetscInt *perm)
    244: {
    245:   PetscInt    i,j,k,p,ld;
    246:   PetscScalar *Q,rtmp;

    248:   ld = ds->ld;
    249:   MatDenseGetArray(ds->omat[mat],&Q);
    250:   for (i=istart;i<iend;i++) {
    251:     p = perm[i];
    252:     if (p != i) {
    253:       j = i + 1;
    254:       while (perm[j] != i) j++;
    255:       perm[j] = p; perm[i] = i;
    256:       /* swap columns i and j */
    257:       for (k=0;k<n;k++) {
    258:         rtmp = Q[k+p*ld]; Q[k+p*ld] = Q[k+i*ld]; Q[k+i*ld] = rtmp;
    259:       }
    260:     }
    261:   }
    262:   MatDenseRestoreArray(ds->omat[mat],&Q);
    263:   return 0;
    264: }

    266: /*
    267:   The same as DSPermuteColumns_Private but for two matrices [mat1] and [mat2]
    268:  */
    269: PetscErrorCode DSPermuteColumnsTwo_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt n,DSMatType mat1,DSMatType mat2,PetscInt *perm)
    270: {
    271:   PetscInt    i,j,k,p,ld;
    272:   PetscScalar *Q,*Z,rtmp,rtmp2;

    274:   ld = ds->ld;
    275:   MatDenseGetArray(ds->omat[mat1],&Q);
    276:   MatDenseGetArray(ds->omat[mat2],&Z);
    277:   for (i=istart;i<iend;i++) {
    278:     p = perm[i];
    279:     if (p != i) {
    280:       j = i + 1;
    281:       while (perm[j] != i) j++;
    282:       perm[j] = p; perm[i] = i;
    283:       /* swap columns i and j */
    284:       for (k=0;k<n;k++) {
    285:         rtmp  = Q[k+p*ld]; Q[k+p*ld] = Q[k+i*ld]; Q[k+i*ld] = rtmp;
    286:         rtmp2 = Z[k+p*ld]; Z[k+p*ld] = Z[k+i*ld]; Z[k+i*ld] = rtmp2;
    287:       }
    288:     }
    289:   }
    290:   MatDenseRestoreArray(ds->omat[mat1],&Q);
    291:   MatDenseRestoreArray(ds->omat[mat2],&Z);
    292:   return 0;
    293: }

    295: /*
    296:   Permute rows [istart..iend-1] of [mat] according to perm. Rows have length m
    297:  */
    298: PetscErrorCode DSPermuteRows_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt m,DSMatType mat,PetscInt *perm)
    299: {
    300:   PetscInt    i,j,k,p,ld;
    301:   PetscScalar *Q,rtmp;

    303:   ld = ds->ld;
    304:   MatDenseGetArray(ds->omat[mat],&Q);
    305:   for (i=istart;i<iend;i++) {
    306:     p = perm[i];
    307:     if (p != i) {
    308:       j = i + 1;
    309:       while (perm[j] != i) j++;
    310:       perm[j] = p; perm[i] = i;
    311:       /* swap rows i and j */
    312:       for (k=0;k<m;k++) {
    313:         rtmp = Q[p+k*ld]; Q[p+k*ld] = Q[i+k*ld]; Q[i+k*ld] = rtmp;
    314:       }
    315:     }
    316:   }
    317:   MatDenseRestoreArray(ds->omat[mat],&Q);
    318:   return 0;
    319: }

    321: /*
    322:   Permute columns [istart..iend-1] of [mat1] and [mat2] according to perm.
    323:   Columns of [mat1] have length n, columns of [mat2] have length m
    324:  */
    325: PetscErrorCode DSPermuteBoth_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt n,PetscInt m,DSMatType mat1,DSMatType mat2,PetscInt *perm)
    326: {
    327:   PetscInt    i,j,k,p,ld;
    328:   PetscScalar *U,*V,rtmp;

    330:   ld = ds->ld;
    331:   MatDenseGetArray(ds->omat[mat1],&U);
    332:   MatDenseGetArray(ds->omat[mat2],&V);
    333:   for (i=istart;i<iend;i++) {
    334:     p = perm[i];
    335:     if (p != i) {
    336:       j = i + 1;
    337:       while (perm[j] != i) j++;
    338:       perm[j] = p; perm[i] = i;
    339:       /* swap columns i and j of U */
    340:       for (k=0;k<n;k++) {
    341:         rtmp = U[k+p*ld]; U[k+p*ld] = U[k+i*ld]; U[k+i*ld] = rtmp;
    342:       }
    343:       /* swap columns i and j of V */
    344:       for (k=0;k<m;k++) {
    345:         rtmp = V[k+p*ld]; V[k+p*ld] = V[k+i*ld]; V[k+i*ld] = rtmp;
    346:       }
    347:     }
    348:   }
    349:   MatDenseRestoreArray(ds->omat[mat1],&U);
    350:   MatDenseRestoreArray(ds->omat[mat2],&V);
    351:   return 0;
    352: }

    354: /*@
    355:    DSSetIdentity - Copy the identity (a diagonal matrix with ones) on the
    356:    active part of a matrix.

    358:    Logically Collective on ds

    360:    Input Parameters:
    361: +  ds  - the direct solver context
    362: -  mat - the matrix to modify

    364:    Level: intermediate

    366: .seealso: DSGetMat()
    367: @*/
    368: PetscErrorCode DSSetIdentity(DS ds,DSMatType mat)
    369: {
    370:   PetscScalar    *A;
    371:   PetscInt       i,ld,n,l;

    375:   DSCheckValidMat(ds,mat,2);

    377:   DSGetDimensions(ds,&n,&l,NULL,NULL);
    378:   DSGetLeadingDimension(ds,&ld);
    379:   PetscLogEventBegin(DS_Other,ds,0,0,0);
    380:   MatDenseGetArray(ds->omat[mat],&A);
    381:   PetscArrayzero(A+l*ld,ld*(n-l));
    382:   for (i=l;i<n;i++) A[i+i*ld] = 1.0;
    383:   MatDenseRestoreArray(ds->omat[mat],&A);
    384:   PetscLogEventEnd(DS_Other,ds,0,0,0);
    385:   return 0;
    386: }

    388: /*@C
    389:    DSOrthogonalize - Orthogonalize the columns of a matrix.

    391:    Logically Collective on ds

    393:    Input Parameters:
    394: +  ds   - the direct solver context
    395: .  mat  - a matrix
    396: -  cols - number of columns to orthogonalize (starting from column zero)

    398:    Output Parameter:
    399: .  lindcols - (optional) number of linearly independent columns of the matrix

    401:    Level: developer

    403: .seealso: DSPseudoOrthogonalize()
    404: @*/
    405: PetscErrorCode DSOrthogonalize(DS ds,DSMatType mat,PetscInt cols,PetscInt *lindcols)
    406: {
    407:   PetscInt       n,l,ld;
    408:   PetscBLASInt   ld_,rA,cA,info,ltau,lw;
    409:   PetscScalar    *A,*tau,*w,saux,dummy;

    412:   DSCheckAlloc(ds,1);
    414:   DSCheckValidMat(ds,mat,2);

    417:   DSGetDimensions(ds,&n,&l,NULL,NULL);
    418:   DSGetLeadingDimension(ds,&ld);
    419:   n = n - l;
    421:   if (n == 0 || cols == 0) return 0;

    423:   PetscLogEventBegin(DS_Other,ds,0,0,0);
    424:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    425:   MatDenseGetArray(ds->omat[mat],&A);
    426:   PetscBLASIntCast(PetscMin(cols,n),&ltau);
    427:   PetscBLASIntCast(ld,&ld_);
    428:   PetscBLASIntCast(n,&rA);
    429:   PetscBLASIntCast(cols,&cA);
    430:   lw = -1;
    431:   PetscCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&rA,&cA,A,&ld_,&dummy,&saux,&lw,&info));
    432:   SlepcCheckLapackInfo("geqrf",info);
    433:   lw = (PetscBLASInt)PetscRealPart(saux);
    434:   DSAllocateWork_Private(ds,lw+ltau,0,0);
    435:   tau = ds->work;
    436:   w = &tau[ltau];
    437:   PetscCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&rA,&cA,&A[ld*l+l],&ld_,tau,w,&lw,&info));
    438:   SlepcCheckLapackInfo("geqrf",info);
    439:   PetscCallBLAS("LAPACKorgqr",LAPACKorgqr_(&rA,&ltau,&ltau,&A[ld*l+l],&ld_,tau,w,&lw,&info));
    440:   SlepcCheckLapackInfo("orgqr",info);
    441:   if (lindcols) *lindcols = ltau;
    442:   PetscFPTrapPop();
    443:   MatDenseRestoreArray(ds->omat[mat],&A);
    444:   PetscLogEventEnd(DS_Other,ds,0,0,0);
    445:   PetscObjectStateIncrease((PetscObject)ds);
    446:   return 0;
    447: }

    449: /*
    450:   Compute C <- a*A*B + b*C, where
    451:     ldC, the leading dimension of C,
    452:     ldA, the leading dimension of A,
    453:     rA, cA, rows and columns of A,
    454:     At, if true use the transpose of A instead,
    455:     ldB, the leading dimension of B,
    456:     rB, cB, rows and columns of B,
    457:     Bt, if true use the transpose of B instead
    458: */
    459: static PetscErrorCode SlepcMatDenseMult(PetscScalar *C,PetscInt _ldC,PetscScalar b,PetscScalar a,const PetscScalar *A,PetscInt _ldA,PetscInt rA,PetscInt cA,PetscBool At,const PetscScalar *B,PetscInt _ldB,PetscInt rB,PetscInt cB,PetscBool Bt)
    460: {
    461:   PetscInt       tmp;
    462:   PetscBLASInt   m, n, k, ldA = _ldA, ldB = _ldB, ldC = _ldC;
    463:   const char     *N = "N", *T = "C", *qA = N, *qB = N;

    465:   if ((rA == 0) || (cB == 0)) return 0;

    470:   /* Transpose if needed */
    471:   if (At) tmp = rA, rA = cA, cA = tmp, qA = T;
    472:   if (Bt) tmp = rB, rB = cB, cB = tmp, qB = T;

    474:   /* Check size */

    477:   /* Do stub */
    478:   if ((rA == 1) && (cA == 1) && (cB == 1)) {
    479:     if (!At && !Bt) *C = *A * *B;
    480:     else if (At && !Bt) *C = PetscConj(*A) * *B;
    481:     else if (!At && Bt) *C = *A * PetscConj(*B);
    482:     else *C = PetscConj(*A) * PetscConj(*B);
    483:     m = n = k = 1;
    484:   } else {
    485:     m = rA; n = cB; k = cA;
    486:     PetscCallBLAS("BLASgemm",BLASgemm_(qA,qB,&m,&n,&k,&a,(PetscScalar*)A,&ldA,(PetscScalar*)B,&ldB,&b,C,&ldC));
    487:   }

    489:   PetscLogFlops(2.0*m*n*k);
    490:   return 0;
    491: }

    493: /*@C
    494:    DSPseudoOrthogonalize - Orthogonalize the columns of a matrix with Modified
    495:    Gram-Schmidt in an indefinite inner product space defined by a signature.

    497:    Logically Collective on ds

    499:    Input Parameters:
    500: +  ds   - the direct solver context
    501: .  mat  - the matrix
    502: .  cols - number of columns to orthogonalize (starting from column zero)
    503: -  s    - the signature that defines the inner product

    505:    Output Parameters:
    506: +  lindcols - (optional) linearly independent columns of the matrix
    507: -  ns   - (optional) the new signature of the vectors

    509:    Note:
    510:    After the call the matrix satisfies A'*s*A = ns.

    512:    Level: developer

    514: .seealso: DSOrthogonalize()
    515: @*/
    516: PetscErrorCode DSPseudoOrthogonalize(DS ds,DSMatType mat,PetscInt cols,PetscReal *s,PetscInt *lindcols,PetscReal *ns)
    517: {
    518:   PetscInt       i,j,k,l,n,ld;
    519:   PetscBLASInt   info,one=1,zero=0,rA_,ld_;
    520:   PetscScalar    *A,*A_,*m,*h,nr0;
    521:   PetscReal      nr_o,nr,nr_abs,*ns_,done=1.0;

    524:   DSCheckAlloc(ds,1);
    526:   DSCheckValidMat(ds,mat,2);
    529:   DSGetDimensions(ds,&n,&l,NULL,NULL);
    530:   DSGetLeadingDimension(ds,&ld);
    531:   n = n - l;
    533:   if (n == 0 || cols == 0) return 0;
    534:   PetscLogEventBegin(DS_Other,ds,0,0,0);
    535:   PetscBLASIntCast(n,&rA_);
    536:   PetscBLASIntCast(ld,&ld_);
    537:   MatDenseGetArray(ds->omat[mat],&A_);
    538:   A = &A_[ld*l+l];
    539:   DSAllocateWork_Private(ds,n+cols,ns?0:cols,0);
    540:   m = ds->work;
    541:   h = &m[n];
    542:   ns_ = ns ? ns : ds->rwork;
    543:   for (i=0; i<cols; i++) {
    544:     /* m <- diag(s)*A[i] */
    545:     for (k=0; k<n; k++) m[k] = s[k]*A[k+i*ld];
    546:     /* nr_o <- mynorm(A[i]'*m), mynorm(x) = sign(x)*sqrt(|x|) */
    547:     SlepcMatDenseMult(&nr0,1,0.0,1.0,&A[ld*i],ld,n,1,PETSC_TRUE,m,n,n,1,PETSC_FALSE);
    548:     nr = nr_o = PetscSign(PetscRealPart(nr0))*PetscSqrtReal(PetscAbsScalar(nr0));
    549:     for (j=0; j<3 && i>0; j++) {
    550:       /* h <- A[0:i-1]'*m */
    551:       SlepcMatDenseMult(h,i,0.0,1.0,A,ld,n,i,PETSC_TRUE,m,n,n,1,PETSC_FALSE);
    552:       /* h <- diag(ns)*h */
    553:       for (k=0; k<i; k++) h[k] *= ns_[k];
    554:       /* A[i] <- A[i] - A[0:i-1]*h */
    555:       SlepcMatDenseMult(&A[ld*i],ld,1.0,-1.0,A,ld,n,i,PETSC_FALSE,h,i,i,1,PETSC_FALSE);
    556:       /* m <- diag(s)*A[i] */
    557:       for (k=0; k<n; k++) m[k] = s[k]*A[k+i*ld];
    558:       /* nr_o <- mynorm(A[i]'*m) */
    559:       SlepcMatDenseMult(&nr0,1,0.0,1.0,&A[ld*i],ld,n,1,PETSC_TRUE,m,n,n,1,PETSC_FALSE);
    560:       nr = PetscSign(PetscRealPart(nr0))*PetscSqrtReal(PetscAbsScalar(nr0));
    562:       if (PetscAbs(nr) > 0.7*PetscAbs(nr_o)) break;
    563:       nr_o = nr;
    564:     }
    565:     ns_[i] = PetscSign(nr);
    566:     /* A[i] <- A[i]/|nr| */
    567:     nr_abs = PetscAbs(nr);
    568:     PetscCallBLAS("LAPACKlascl",LAPACKlascl_("G",&zero,&zero,&nr_abs,&done,&rA_,&one,A+i*ld,&ld_,&info));
    569:     SlepcCheckLapackInfo("lascl",info);
    570:   }
    571:   MatDenseRestoreArray(ds->omat[mat],&A_);
    572:   PetscLogEventEnd(DS_Other,ds,0,0,0);
    573:   PetscObjectStateIncrease((PetscObject)ds);
    574:   if (lindcols) *lindcols = cols;
    575:   return 0;
    576: }