lammps/lib/linalg/dhseqr.cpp

#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b11 = 0.;
static doublereal c_b12 = 1.;
static integer c__12 = 12;
static integer c__2 = 2;
static integer c__49 = 49;
int dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h__,
            integer *ldh, doublereal *wr, doublereal *wi, doublereal *z__, integer *ldz,
            doublereal *work, integer *lwork, integer *info, ftnlen job_len, ftnlen compz_len)
{
    address a__1[2];
    integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3;
    doublereal d__1;
    char ch__1[2];
    int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
    integer i__;
    doublereal hl[2401];
    integer kbot, nmin;
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    logical initz;
    doublereal workl[49];
    logical wantt, wantz;
    extern int dlaqr0_(logical *, logical *, integer *, integer *, integer *, doublereal *,
                       integer *, doublereal *, doublereal *, integer *, integer *, doublereal *,
                       integer *, doublereal *, integer *, integer *),
        dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
                doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
                integer *),
        dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
                ftnlen),
        dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
                ftnlen);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
                           ftnlen, ftnlen);
    extern int xerbla_(char *, integer *, ftnlen);
    logical lquery;
    h_dim1 = *ldh;
    h_offset = 1 + h_dim1;
    h__ -= h_offset;
    --wr;
    --wi;
    z_dim1 = *ldz;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    --work;
    wantt = lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1);
    initz = lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1);
    wantz = initz || lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1);
    work[1] = (doublereal)max(1, *n);
    lquery = *lwork == -1;
    *info = 0;
    if (!lsame_(job, (char *)"E", (ftnlen)1, (ftnlen)1) && !wantt) {
        *info = -1;
    } else if (!lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1) && !wantz) {
        *info = -2;
    } else if (*n < 0) {
        *info = -3;
    } else if (*ilo < 1 || *ilo > max(1, *n)) {
        *info = -4;
    } else if (*ihi < min(*ilo, *n) || *ihi > *n) {
        *info = -5;
    } else if (*ldh < max(1, *n)) {
        *info = -7;
    } else if (*ldz < 1 || wantz && *ldz < max(1, *n)) {
        *info = -11;
    } else if (*lwork < max(1, *n) && !lquery) {
        *info = -13;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_((char *)"DHSEQR", &i__1, (ftnlen)6);
        return 0;
    } else if (*n == 0) {
        return 0;
    } else if (lquery) {
        dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi,
                &z__[z_offset], ldz, &work[1], lwork, info);
        d__1 = (doublereal)max(1, *n);
        work[1] = max(d__1, work[1]);
        return 0;
    } else {
        i__1 = *ilo - 1;
        for (i__ = 1; i__ <= i__1; ++i__) {
            wr[i__] = h__[i__ + i__ * h_dim1];
            wi[i__] = 0.;
        }
        i__1 = *n;
        for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
            wr[i__] = h__[i__ + i__ * h_dim1];
            wi[i__] = 0.;
        }
        if (initz) {
            dlaset_((char *)"A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz, (ftnlen)1);
        }
        if (*ilo == *ihi) {
            wr[*ilo] = h__[*ilo + *ilo * h_dim1];
            wi[*ilo] = 0.;
            return 0;
        }
        i__2[0] = 1, a__1[0] = job;
        i__2[1] = 1, a__1[1] = compz;
        s_lmp_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
        nmin = ilaenv_(&c__12, (char *)"DHSEQR", ch__1, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
        nmin = max(11, nmin);
        if (*n > nmin) {
            dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi,
                    &z__[z_offset], ldz, &work[1], lwork, info);
        } else {
            dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi,
                    &z__[z_offset], ldz, info);
            if (*info > 0) {
                kbot = *info;
                if (*n >= 49) {
                    dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], ldh, &wr[1], &wi[1], ilo,
                            ihi, &z__[z_offset], ldz, &work[1], lwork, info);
                } else {
                    dlacpy_((char *)"A", n, n, &h__[h_offset], ldh, hl, &c__49, (ftnlen)1);
                    hl[*n + 1 + *n * 49 - 50] = 0.;
                    i__1 = 49 - *n;
                    dlaset_((char *)"A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * 49 - 49], &c__49,
                            (ftnlen)1);
                    dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &wr[1], &wi[1], ilo,
                            ihi, &z__[z_offset], ldz, workl, &c__49, info);
                    if (wantt || *info != 0) {
                        dlacpy_((char *)"A", n, n, hl, &c__49, &h__[h_offset], ldh, (ftnlen)1);
                    }
                }
            }
        }
        if ((wantt || *info != 0) && *n > 2) {
            i__1 = *n - 2;
            i__3 = *n - 2;
            dlaset_((char *)"L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh, (ftnlen)1);
        }
        d__1 = (doublereal)max(1, *n);
        work[1] = max(d__1, work[1]);
    }
    return 0;
}
#ifdef __cplusplus
}
#endif