Date: 2016-03-29T14:56:48+00:00

Actual source code: dlaed3m.c
slepc-3.6.3 2016-03-29
Report Typos and Errors

      1: /*
      2:    BDC - Block-divide and conquer (see description in README file).

      4:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      5:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      6:    Copyright (c) 2002-2015, Universitat Politecnica de Valencia, Spain

      8:    This file is part of SLEPc.

     10:    SLEPc is free software: you can redistribute it and/or modify it under  the
     11:    terms of version 3 of the GNU Lesser General Public License as published by
     12:    the Free Software Foundation.

     14:    SLEPc  is  distributed in the hope that it will be useful, but WITHOUT  ANY
     15:    WARRANTY;  without even the implied warranty of MERCHANTABILITY or  FITNESS
     16:    FOR  A  PARTICULAR PURPOSE. See the GNU Lesser General Public  License  for
     17:    more details.

     19:    You  should have received a copy of the GNU Lesser General  Public  License
     20:    along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
     21:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     22: */

     24: #include <slepc/private/dsimpl.h>
     25: #include <slepcblaslapack.h>

     27: PetscErrorCode BDC_dlaed3m_(const char *jobz,const char *defl,PetscBLASInt k,PetscBLASInt n,
     28:         PetscBLASInt n1,PetscReal *d,PetscReal *q,PetscBLASInt ldq,
     29:         PetscReal rho,PetscReal *dlamda,PetscReal *q2,PetscBLASInt *indx,
     30:         PetscBLASInt *ctot,PetscReal *w,PetscReal *s,PetscBLASInt *info,
     31:         PetscBLASInt jobz_len,PetscBLASInt defl_len)
     32: {
     33: /*  -- Routine written in LAPACK version 3.0 style -- */
     34: /* *************************************************** */
     35: /*     Written by */
     36: /*     Michael Moldaschl and Wilfried Gansterer */
     37: /*     University of Vienna */
     38: /*     last modification: March 16, 2014 */

     40: /*     Small adaptations of original code written by */
     41: /*     Wilfried Gansterer and Bob Ward, */
     42: /*     Department of Computer Science, University of Tennessee */
     43: /*     see http://dx.doi.org/10.1137/S1064827501399432 */
     44: /* *************************************************** */

     46: /*  Purpose */
     47: /*  ======= */

     49: /*  DLAED3M finds the roots of the secular equation, as defined by the */
     50: /*  values in D, W, and RHO, between 1 and K.  It makes the */
     51: /*  appropriate calls to DLAED4 and then updates the eigenvectors by */
     52: /*  multiplying the matrix of eigenvectors of the pair of eigensystems */
     53: /*  being combined by the matrix of eigenvectors of the K-by-K system */
     54: /*  which is solved here. */

     56: /*  This code makes very mild assumptions about floating point */
     57: /*  arithmetic. It will work on machines with a guard digit in */
     58: /*  add/subtract, or on those binary machines without guard digits */
     59: /*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
     60: /*  It could conceivably fail on hexadecimal or decimal machines */
     61: /*  without guard digits, but we know of none. */

     63: /*  Arguments */
     64: /*  ========= */

     66: /*  JOBZ    (input) CHARACTER*1 */
     67: /*          = 'N':  Do not accumulate eigenvectors (not implemented); */
     68: /*          = 'D':  Do accumulate eigenvectors in the divide-and-conquer */
     69: /*                  process. */

     71: /*  DEFL    (input) CHARACTER*1 */
     72: /*          = '0':  No deflation happened in DSRTDF */
     73: /*          = '1':  Some deflation happened in DSRTDF (and therefore some */
     74: /*                  Givens rotations need to be applied to the computed */
     75: /*                  eigenvector matrix Q) */

     77: /*  K       (input) INTEGER */
     78: /*          The number of terms in the rational function to be solved by */
     79: /*          DLAED4. 0 <= K <= N. */

     81: /*  N       (input) INTEGER */
     82: /*          The number of rows and columns in the Q matrix. */
     83: /*          N >= K (deflation may result in N>K). */

     85: /*  N1      (input) INTEGER */
     86: /*          The location of the last eigenvalue in the leading submatrix. */
     87: /*          min(1,N) <= N1 <= max(1,N-1). */

     89: /*  D       (output) DOUBLE PRECISION array, dimension (N) */
     90: /*          D(I) contains the updated eigenvalues for */
     91: /*          1 <= I <= K. */

     93: /*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N) */
     94: /*          Initially the first K columns are used as workspace. */
     95: /*          On output the columns 1 to K contain */
     96: /*          the updated eigenvectors. */

     98: /*  LDQ     (input) INTEGER */
     99: /*          The leading dimension of the array Q.  LDQ >= max(1,N). */

    101: /*  RHO     (input) DOUBLE PRECISION */
    102: /*          The value of the parameter in the rank one update equation. */
    103: /*          RHO >= 0 required. */

    105: /*  DLAMDA  (input/output) DOUBLE PRECISION array, dimension (K) */
    106: /*          The first K elements of this array contain the old roots */
    107: /*          of the deflated updating problem.  These are the poles */
    108: /*          of the secular equation. May be changed on output by */
    109: /*          having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
    110: /*          Cray-2, or Cray C-90, as described above. */

    112: /*  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2, N) */
    113: /*          The first K columns of this matrix contain the non-deflated */
    114: /*          eigenvectors for the split problem. */

    116: /*  INDX    (input) INTEGER array, dimension (N) */
    117: /*          The permutation used to arrange the columns of the deflated */
    118: /*          Q matrix into three groups (see DLAED2). */
    119: /*          The rows of the eigenvectors found by DLAED4 must be likewise */
    120: /*          permuted before the matrix multiply can take place. */

    122: /*  CTOT    (input) INTEGER array, dimension (4) */
    123: /*          A count of the total number of the various types of columns */
    124: /*          in Q, as described in INDX.  The fourth column type is any */
    125: /*          column which has been deflated. */

    127: /*  W       (input/output) DOUBLE PRECISION array, dimension (K) */
    128: /*          The first K elements of this array contain the components */
    129: /*          of the deflation-adjusted updating vector. Destroyed on */
    130: /*          output. */

    132: /*  S       (workspace) DOUBLE PRECISION array, dimension */
    133: /*          ( MAX(CTOT(1)+CTOT(2),CTOT(2)+CTOT(3)) + 1 )*K */
    134: /*          Will contain parts of the eigenvectors of the repaired matrix */
    135: /*          which will be multiplied by the previously accumulated */
    136: /*          eigenvectors to update the system. This array is a major */
    137: /*          source of workspace requirements ! */

    139: /*  INFO    (output) INTEGER */
    140: /*          = 0:  successful exit. */
    141: /*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
    142: /*          > 0:  if INFO = i, eigenpair i was not computed successfully */

    144: /*  Further Details */
    145: /*  =============== */

    147: /*  Based on code written by */
    148: /*     Wilfried Gansterer and Bob Ward, */
    149: /*     Department of Computer Science, University of Tennessee */
    150: /*  Based on the design of the LAPACK code DLAED3 with small modifications */
    151: /*  (Note that in contrast to the original DLAED3, this routine */
    152: /*  DOES NOT require that N1 <= N/2) */

    154: /*  Based on contributions by */
    155: /*     Jeff Rutter, Computer Science Division, University of California */
    156: /*     at Berkeley, USA */
    157: /*  Modified by Francoise Tisseur, University of Tennessee. */

    159: /*  ===================================================================== */

    161: #if defined(SLEPC_MISSING_LAPACK_LAED4) || defined(SLEPC_MISSING_LAPACK_LACPY) || defined(SLEPC_MISSING_LAPACK_LASET)
    163:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"LAED4/LACPY/LASET - Lapack routine is unavailable");
    164: #else
    165:   PetscReal    temp, done = 1.0, dzero = 0.0;
    166:   PetscBLASInt i, j, n2, n12, ii, n23, iq2, i1, one=1;

    169:   *info = 0;

    171:   if (k < 0) {
    172:     *info = -3;
    173:   } else if (n < k) {
    174:     *info = -4;
    175:   } else if (n1 < PetscMin(1,n) || n1 > PetscMax(1,n)) {
    176:     *info = -5;
    177:   } else if (ldq < PetscMax(1,n)) {
    178:     *info = -8;
    179:   } else if (rho < 0.) {
    180:     *info = -9;
    181:   }
    182:   if (*info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONG,"Wrong argument %d in DLAED3M",-(*info));

    184:   /* Quick return if possible */

    186:   if (k == 0) return(0);

    188:   /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
    189:   /* be computed with high relative accuracy (barring over/underflow). */
    190:   /* This is a problem on machines without a guard digit in */
    191:   /* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
    192:   /* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
    193:   /* which on any of these machines zeros out the bottommost */
    194:   /* bit of DLAMDA(I) if it is 1; this makes the subsequent */
    195:   /* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
    196:   /* occurs. On binary machines with a guard digit (almost all */
    197:   /* machines) it does not change DLAMDA(I) at all. On hexadecimal */
    198:   /* and decimal machines with a guard digit, it slightly */
    199:   /* changes the bottommost bits of DLAMDA(I). It does not account */
    200:   /* for hexadecimal or decimal machines without guard digits */
    201:   /* (we know of none). We use a subroutine call to compute */
    202:   /* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
    203:   /* this code. */

    205:   for (i = 0; i < k; ++i) {
    206:     dlamda[i] = LAPACKlamc3_(&dlamda[i], &dlamda[i]) - dlamda[i];
    207:   }

    209:   for (j = 1; j <= k; ++j) {

    211:     /* ....calling DLAED4 for eigenpair J.... */

    213:     PetscStackCallBLAS("LAPACKlaed4",LAPACKlaed4_(&k, &j, dlamda, w, &q[(j-1)*ldq], &rho, &d[j-1], info));
    214:     if (*info) SETERRQ3(PETSC_COMM_SELF,1,"Error in dlaed4, info = %d, failed when computing D(%d)=%g",*info,j,d[j-1]);

    216:     if (j < k) {

    218:       /* If the zero finder terminated properly, but the computed */
    219:       /* eigenvalues are not ordered, issue an error statement */
    220:       /* but continue computation. */

    222:       if (dlamda[j-1] >= dlamda[j]) SETERRQ2(PETSC_COMM_SELF,1,"DLAMDA(%d) is greater or equal than DLAMDA(%d)", j, j+1);
    223:       if (d[j-1] < dlamda[j-1] || d[j-1] > dlamda[j]) SETERRQ6(PETSC_COMM_SELF,1,"DLAMDA(%d) = %g D(%d) = %g DLAMDA(%d) = %g", j, dlamda[j-1], j, d[j-1], j+1, dlamda[j]);
    224:     }
    225:   }

    227:   if (k == 1) goto L110;

    229:   if (k == 2) {

    231:     /* permute the components of Q(:,J) (the information returned by DLAED4 */
    232:     /* necessary to construct the eigenvectors) according to the permutation */
    233:     /* stored in INDX, resulting from deflation */

    235:     for (j = 0; j < k; ++j) {
    236:       w[0] = q[0+j*ldq];
    237:       w[1] = q[1+j*ldq];
    238:       ii = indx[0];
    239:       q[0+j*ldq] = w[ii-1];
    240:       ii = indx[1];
    241:       q[1+j*ldq] = w[ii-1];
    242:     }
    243:     goto L110;
    244:   }

    246:   /* ....K.GE.3.... */
    247:   /* Compute updated W (used for computing the eigenvectors corresponding */
    248:   /* to the previously computed eigenvalues). */

    250:   PetscStackCallBLAS("BLAScopy",BLAScopy_(&k, w, &one, s, &one));

    252:   /* Initialize W(I) = Q(I,I) */

    254:   i1 = ldq + 1;
    255:   PetscStackCallBLAS("BLAScopy",BLAScopy_(&k, q, &i1, w, &one));
    256:   for (j = 0; j < k; ++j) {
    257:     for (i = 0; i < j; ++i) {
    258:       w[i] *= q[i+j*ldq] / (dlamda[i] - dlamda[j]);
    259:     }
    260:     for (i = j + 1; i < k; ++i) {
    261:       w[i] *= q[i+j*ldq] / (dlamda[i] - dlamda[j]);
    262:     }
    263:   }
    264:   for (i = 0; i < k; ++i) {
    265:     temp = PetscSqrtReal(-w[i]);
    266:     if (temp<0) temp = -temp;
    267:     w[i] =  (s[i] >= 0) ? temp : -temp;
    268:   }

    270:   /* Compute eigenvectors of the modified rank-1 modification (using the */
    271:   /* vector W). */

    273:   for (j = 0; j < k; ++j) {
    274:     for (i = 0; i < k; ++i) {
    275:       s[i] = w[i] / q[i+j*ldq];
    276:     }
    277:     temp = BLASnrm2_(&k, s, &one);
    278:     for (i = 0; i < k; ++i) {

    280:       /* apply the permutation resulting from deflation as stored */
    281:       /* in INDX */

    283:       ii = indx[i];
    284:       q[i+j*ldq] = s[ii-1] / temp;
    285:     }
    286:   }

    288: /* ************************************************************************** */

    290:   /* ....updating the eigenvectors.... */

    292: L110:

    294:   n2 = n - n1;
    295:   n12 = ctot[0] + ctot[1];
    296:   n23 = ctot[1] + ctot[2];
    297:   if (*(unsigned char *)jobz == 'D') {

    299:     /* Compute the updated eigenvectors. (NOTE that every call of */
    300:     /* DGEMM requires three DISTINCT arrays) */

    302:     /* copy Q( CTOT(1)+1:K,1:K ) to S */

    304:     PetscStackCallBLAS("LAPACKlacpy",LAPACKlacpy_("A", &n23, &k, &q[ctot[0]], &ldq, s, &n23));
    305:     iq2 = n1 * n12 + 1;

    307:     if (n23 != 0) {

    309:       /* multiply the second part of Q2 (the eigenvectors of the */
    310:       /* lower block) with S and write the result into the lower part of */
    311:       /* Q, i.e., Q( N1+1:N,1:K ) */

    313:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N", "N", &n2, &k, &n23, &done,
    314:                   &q2[iq2-1], &n2, s, &n23, &dzero, &q[n1], &ldq));
    315:     } else {
    316:       PetscStackCallBLAS("LAPACKlaset",LAPACKlaset_("A", &n2, &k, &dzero, &dzero, &q[n1], &ldq));
    317:     }

    319:     /* copy Q( 1:CTOT(1)+CTOT(2),1:K ) to S */

    321:     PetscStackCallBLAS("LAPACKlacpy",LAPACKlacpy_("A", &n12, &k, q, &ldq, s, &n12));

    323:     if (n12 != 0) {

    325:       /* multiply the first part of Q2 (the eigenvectors of the */
    326:       /* upper block) with S and write the result into the upper part of */
    327:       /* Q, i.e., Q( 1:N1,1:K ) */

    329:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N", "N", &n1, &k, &n12, &done,
    330:                   q2, &n1, s, &n12, &dzero, q, &ldq));
    331:     } else {
    332:       PetscStackCallBLAS("LAPACKlaset",LAPACKlaset_("A", &n1, &k, &dzero, &dzero, q, &ldq));
    333:     }
    334:   }
    335:   return(0);
    336: #endif
    337: }