Example #1
0
def rq(a, overwrite_a=False, lwork=None):
    """Compute RQ decomposition of a square real matrix.

    Calculate the decomposition :lm:`A = R Q` where Q is unitary/orthogonal
    and R upper triangular.

    Parameters
    ----------
    a : array, shape (M, M)
        Square real matrix to be decomposed
    overwrite_a : boolean
        Whether data in a is overwritten (may improve performance)
    lwork : integer
        Work array size, lwork >= a.shape[1]. If None or -1, an optimal size
        is computed.
    econ : boolean

    Returns
    -------
    R : double array, shape (M, N) or (K, N) for econ==True
        Size K = min(M, N)
    Q : double or complex array, shape (M, M) or (M, K) for econ==True

    Raises LinAlgError if decomposition fails

    """
    # TODO: implement support for non-square and complex arrays
    a1 = asarray_chkfinite(a)
    if len(a1.shape) != 2:
        raise ValueError('expected matrix')
    M, N = a1.shape
    if M != N:
        raise ValueError('expected square matrix')
    if issubclass(a1.dtype.type, complexfloating):
        raise ValueError('expected real (non-complex) matrix')
    overwrite_a = overwrite_a or (_datanotshared(a1, a))
    gerqf, = get_lapack_funcs(('gerqf', ), (a1, ))
    if lwork is None or lwork == -1:
        # get optimal work array
        rq, tau, work, info = gerqf(a1, lwork=-1, overwrite_a=1)
        lwork = work[0]
    rq, tau, work, info = gerqf(a1, lwork=lwork, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal geqrf' %
                         -info)
    gemm, = get_blas_funcs(('gemm', ), (rq, ))
    t = rq.dtype.char
    R = special_matrices.triu(rq)
    Q = numpy.identity(M, dtype=t)
    ident = numpy.identity(M, dtype=t)
    zeros = numpy.zeros

    k = min(M, N)
    for i in range(k):
        v = zeros((M, ), t)
        v[N - k + i] = 1
        v[0:N - k + i] = rq[M - k + i, 0:N - k + i]
        H = gemm(-tau[i], v, v, 1 + 0j, ident, trans_b=2)
        Q = gemm(1, Q, H)
    return R, Q
def rq(a, overwrite_a=False, lwork=None):
    """Compute RQ decomposition of a square real matrix.

    Calculate the decomposition :lm:`A = R Q` where Q is unitary/orthogonal
    and R upper triangular.

    Parameters
    ----------
    a : array, shape (M, M)
        Square real matrix to be decomposed
    overwrite_a : boolean
        Whether data in a is overwritten (may improve performance)
    lwork : integer
        Work array size, lwork >= a.shape[1]. If None or -1, an optimal size
        is computed.
    econ : boolean

    Returns
    -------
    R : double array, shape (M, N) or (K, N) for econ==True
        Size K = min(M, N)
    Q : double or complex array, shape (M, M) or (M, K) for econ==True

    Raises LinAlgError if decomposition fails

    """
    # TODO: implement support for non-square and complex arrays
    a1 = asarray_chkfinite(a)
    if len(a1.shape) != 2:
        raise ValueError('expected matrix')
    M,N = a1.shape
    if M != N:
        raise ValueError('expected square matrix')
    if issubclass(a1.dtype.type, complexfloating):
        raise ValueError('expected real (non-complex) matrix')
    overwrite_a = overwrite_a or (_datanotshared(a1, a))
    gerqf, = get_lapack_funcs(('gerqf',), (a1,))
    if lwork is None or lwork == -1:
        # get optimal work array
        rq, tau, work, info = gerqf(a1, lwork=-1, overwrite_a=1)
        lwork = work[0]
    rq, tau, work, info = gerqf(a1, lwork=lwork, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal geqrf'
                                                                    % -info)
    gemm, = get_blas_funcs(('gemm',), (rq,))
    t = rq.dtype.char
    R = special_matrices.triu(rq)
    Q = numpy.identity(M, dtype=t)
    ident = numpy.identity(M, dtype=t)
    zeros = numpy.zeros

    k = min(M, N)
    for i in range(k):
        v = zeros((M,), t)
        v[N-k+i] = 1
        v[0:N-k+i] = rq[M-k+i, 0:N-k+i]
        H = gemm(-tau[i], v, v, 1+0j, ident, trans_b=2)
        Q = gemm(1, Q, H)
    return R, Q
Example #3
0
def qr_old(a, overwrite_a=False, lwork=None, check_finite=True):
    """Compute QR decomposition of a matrix.

    Calculate the decomposition :lm:`A = Q R` where Q is unitary/orthogonal
    and R upper triangular.

    Parameters
    ----------
    a : array, shape (M, N)
        Matrix to be decomposed
    overwrite_a : boolean
        Whether data in a is overwritten (may improve performance)
    lwork : integer
        Work array size, lwork >= a.shape[1]. If None or -1, an optimal size
        is computed.
    check_finite : boolean, optional
        Whether to check the input matrixes contain only finite numbers.
        Disabling may give a performance gain, but may result to problems
        (crashes, non-termination) if the inputs do contain infinities or NaNs.

    Returns
    -------
    Q : float or complex array, shape (M, M)
    R : float or complex array, shape (M, N)
        Size K = min(M, N)

    Raises LinAlgError if decomposition fails

    """
    if check_finite:
        a1 = numpy.asarray_chkfinite(a)
    else:
        a1 = numpy.asarray(a)
    if len(a1.shape) != 2:
        raise ValueError('expected matrix')
    M,N = a1.shape
    overwrite_a = overwrite_a or (_datacopied(a1, a))
    geqrf, = get_lapack_funcs(('geqrf',), (a1,))
    if lwork is None or lwork == -1:
        # get optimal work array
        qr, tau, work, info = geqrf(a1, lwork=-1, overwrite_a=1)
        lwork = work[0]
    qr, tau, work, info = geqrf(a1, lwork=lwork, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal geqrf'
                                                                    % -info)
    gemm, = get_blas_funcs(('gemm',), (qr,))
    t = qr.dtype.char
    R = numpy.triu(qr)
    Q = numpy.identity(M, dtype=t)
    ident = numpy.identity(M, dtype=t)
    zeros = numpy.zeros
    for i in range(min(M, N)):
        v = zeros((M,), t)
        v[i] = 1
        v[i+1:M] = qr[i+1:M, i]
        H = gemm(-tau[i], v, v, 1+0j, ident, trans_b=2)
        Q = gemm(1, Q, H)
    return Q, R
Example #4
0
def qr_old(a, overwrite_a=False, lwork=None, check_finite=True):
    """Compute QR decomposition of a matrix.

    Calculate the decomposition :lm:`A = Q R` where Q is unitary/orthogonal
    and R upper triangular.

    Parameters
    ----------
    a : array, shape (M, N)
        Matrix to be decomposed
    overwrite_a : boolean
        Whether data in a is overwritten (may improve performance)
    lwork : integer
        Work array size, lwork >= a.shape[1]. If None or -1, an optimal size
        is computed.
    check_finite : boolean, optional
        Whether to check the input matrixes contain only finite numbers.
        Disabling may give a performance gain, but may result to problems
        (crashes, non-termination) if the inputs do contain infinities or NaNs.

    Returns
    -------
    Q : float or complex array, shape (M, M)
    R : float or complex array, shape (M, N)
        Size K = min(M, N)

    Raises LinAlgError if decomposition fails

    """
    if check_finite:
        a1 = numpy.asarray_chkfinite(a)
    else:
        a1 = numpy.asarray(a)
    if len(a1.shape) != 2:
        raise ValueError('expected matrix')
    M, N = a1.shape
    overwrite_a = overwrite_a or (_datacopied(a1, a))
    geqrf, = get_lapack_funcs(('geqrf', ), (a1, ))
    if lwork is None or lwork == -1:
        # get optimal work array
        qr, tau, work, info = geqrf(a1, lwork=-1, overwrite_a=1)
        lwork = work[0]
    qr, tau, work, info = geqrf(a1, lwork=lwork, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal geqrf' %
                         -info)
    gemm, = get_blas_funcs(('gemm', ), (qr, ))
    t = qr.dtype.char
    R = numpy.triu(qr)
    Q = numpy.identity(M, dtype=t)
    ident = numpy.identity(M, dtype=t)
    zeros = numpy.zeros
    for i in range(min(M, N)):
        v = zeros((M, ), t)
        v[i] = 1
        v[i + 1:M] = qr[i + 1:M, i]
        H = gemm(-tau[i], v, v, 1 + 0j, ident, trans_b=2)
        Q = gemm(1, Q, H)
    return Q, R
Example #5
0
def hessenberg(a,calc_q=0,overwrite_a=0):
    """ Compute Hessenberg form of a matrix.

    Inputs:

      a -- the matrix
      calc_q -- if non-zero then calculate unitary similarity
                transformation matrix q.
      overwrite_a=0 -- if non-zero then discard the contents of a,
                     i.e. a is used as a work array if possible.

    Outputs:

      h    -- Hessenberg form of a                [calc_q=0]
      h, q -- matrices such that a = q * h * q^T  [calc_q=1]

    """
    a1 = asarray(a)
    if len(a1.shape) != 2 or (a1.shape[0] != a1.shape[1]):
        raise ValueError, 'expected square matrix'
    overwrite_a = overwrite_a or (_datanotshared(a1,a))
    gehrd,gebal = get_lapack_funcs(('gehrd','gebal'),(a1,))
    ba,lo,hi,pivscale,info = gebal(a,permute=1,overwrite_a = overwrite_a)
    if info<0: raise ValueError,\
       'illegal value in %-th argument of internal gebal (hessenberg)'%(-info)
    n = len(a1)
    lwork = calc_lwork.gehrd(gehrd.prefix,n,lo,hi)
    hq,tau,info = gehrd(ba,lo=lo,hi=hi,lwork=lwork,overwrite_a=1)
    if info<0: raise ValueError,\
       'illegal value in %-th argument of internal gehrd (hessenberg)'%(-info)

    if not calc_q:
        for i in range(lo,hi):
            hq[i+2:hi+1,i] = 0.0
        return hq

    # XXX: Use ORGHR routines to compute q.
    ger,gemm = get_blas_funcs(('ger','gemm'),(hq,))
    typecode = hq.dtype.char
    q = None
    for i in range(lo,hi):
        if tau[i]==0.0:
            continue
        v = zeros(n,dtype=typecode)
        v[i+1] = 1.0
        v[i+2:hi+1] = hq[i+2:hi+1,i]
        hq[i+2:hi+1,i] = 0.0
        h = ger(-tau[i],v,v,a=diag(ones(n,dtype=typecode)),overwrite_a=1)
        if q is None:
            q = h
        else:
            q = gemm(1.0,q,h)
    if q is None:
        q = diag(ones(n,dtype=typecode))
    return hq,q
Example #6
0
def rq(a,overwrite_a=0,lwork=None):
    """RQ decomposition of an M x N matrix a.

    Description:

      Find an upper-triangular matrix r and a unitary (orthogonal)
      matrix q such that r * q = a

    Inputs:

      a -- the matrix
      overwrite_a=0 -- if non-zero then discard the contents of a,
                     i.e. a is used as a work array if possible.

      lwork=None -- >= shape(a)[1]. If None (or -1) compute optimal
                    work array size.

    Outputs:

      r, q -- matrices such that r * q = a

    """
    # TODO: implement support for non-square and complex arrays
    a1 = asarray_chkfinite(a)
    if len(a1.shape) != 2:
        raise ValueError, 'expected matrix'
    M,N = a1.shape
    if M != N:
        raise ValueError, 'expected square matrix'
    if issubclass(a1.dtype.type,complexfloating):
        raise ValueError, 'expected real (non-complex) matrix'
    overwrite_a = overwrite_a or (_datanotshared(a1,a))
    gerqf, = get_lapack_funcs(('gerqf',),(a1,))
    if lwork is None or lwork == -1:
        # get optimal work array
        rq,tau,work,info = gerqf(a1,lwork=-1,overwrite_a=1)
        lwork = work[0]
    rq,tau,work,info = gerqf(a1,lwork=lwork,overwrite_a=overwrite_a)
    if info<0: raise ValueError, \
       'illegal value in %-th argument of internal geqrf'%(-info)
    gemm, = get_blas_funcs(('gemm',),(rq,))
    t = rq.dtype.char
    R = basic.triu(rq)
    Q = numpy.identity(M,dtype=t)
    ident = numpy.identity(M,dtype=t)
    zeros = numpy.zeros

    k = min(M,N)
    for i in range(k):
        v = zeros((M,),t)
        v[N-k+i] = 1
        v[0:N-k+i] = rq[M-k+i,0:N-k+i]
        H = gemm(-tau[i],v,v,1+0j,ident,trans_b=2)
        Q = gemm(1,Q,H)
    return R, Q
Example #7
0
def qr_old(a, overwrite_a=False, lwork=None):
    """Compute QR decomposition of a matrix.

    Calculate the decomposition :lm:`A = Q R` where Q is unitary/orthogonal
    and R upper triangular.

    Parameters
    ----------
    a : array, shape (M, N)
        Matrix to be decomposed
    overwrite_a : boolean
        Whether data in a is overwritten (may improve performance)
    lwork : integer
        Work array size, lwork >= a.shape[1]. If None or -1, an optimal size
        is computed.

    Returns
    -------
    Q : double or complex array, shape (M, M)
    R : double or complex array, shape (M, N)
        Size K = min(M, N)

    Raises LinAlgError if decomposition fails

    """
    a1 = asarray_chkfinite(a)
    if len(a1.shape) != 2:
        raise ValueError('expected matrix')
    M,N = a1.shape
    overwrite_a = overwrite_a or (_datacopied(a1, a))
    geqrf, = get_lapack_funcs(('geqrf',), (a1,))
    if lwork is None or lwork == -1:
        # get optimal work array
        qr, tau, work, info = geqrf(a1, lwork=-1, overwrite_a=1)
        lwork = work[0]
    qr, tau, work, info = geqrf(a1, lwork=lwork, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal geqrf'
                                                                    % -info)
    gemm, = get_blas_funcs(('gemm',), (qr,))
    t = qr.dtype.char
    R = special_matrices.triu(qr)
    Q = numpy.identity(M, dtype=t)
    ident = numpy.identity(M, dtype=t)
    zeros = numpy.zeros
    for i in range(min(M, N)):
        v = zeros((M,), t)
        v[i] = 1
        v[i+1:M] = qr[i+1:M, i]
        H = gemm(-tau[i], v, v, 1, ident, trans_b=2)
        Q = gemm(1, Q, H)
    return Q, R
Example #8
0
def qr_old(a, overwrite_a=False, lwork=None):
    """Compute QR decomposition of a matrix.

    Calculate the decomposition :lm:`A = Q R` where Q is unitary/orthogonal
    and R upper triangular.

    Parameters
    ----------
    a : array, shape (M, N)
        Matrix to be decomposed
    overwrite_a : boolean
        Whether data in a is overwritten (may improve performance)
    lwork : integer
        Work array size, lwork >= a.shape[1]. If None or -1, an optimal size
        is computed.

    Returns
    -------
    Q : double or complex array, shape (M, M)
    R : double or complex array, shape (M, N)
        Size K = min(M, N)

    Raises LinAlgError if decomposition fails

    """
    a1 = asarray_chkfinite(a)
    if len(a1.shape) != 2:
        raise ValueError('expected matrix')
    M,N = a1.shape
    overwrite_a = overwrite_a or (_datanotshared(a1, a))
    geqrf, = get_lapack_funcs(('geqrf',), (a1,))
    if lwork is None or lwork == -1:
        # get optimal work array
        qr, tau, work, info = geqrf(a1, lwork=-1, overwrite_a=1)
        lwork = work[0]
    qr, tau, work, info = geqrf(a1, lwork=lwork, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal geqrf'
                                                                    % -info)
    gemm, = get_blas_funcs(('gemm',), (qr,))
    t = qr.dtype.char
    R = special_matrices.triu(qr)
    Q = numpy.identity(M, dtype=t)
    ident = numpy.identity(M, dtype=t)
    zeros = numpy.zeros
    for i in range(min(M, N)):
        v = zeros((M,), t)
        v[i] = 1
        v[i+1:M] = qr[i+1:M, i]
        H = gemm(-tau[i], v, v, 1+0j, ident, trans_b=2)
        Q = gemm(1, Q, H)
    return Q, R
Example #9
0
def qr_old(a,overwrite_a=0,lwork=None):
    """QR decomposition of an M x N matrix a.

    Description:

      Find a unitary (orthogonal) matrix, q, and an upper-triangular
      matrix r such that q * r = a

    Inputs:

      a -- the matrix
      overwrite_a=0 -- if non-zero then discard the contents of a,
                     i.e. a is used as a work array if possible.

      lwork=None -- >= shape(a)[1]. If None (or -1) compute optimal
                    work array size.

    Outputs:

      q, r -- matrices such that q * r = a

    """
    a1 = asarray_chkfinite(a)
    if len(a1.shape) != 2:
        raise ValueError, 'expected matrix'
    M,N = a1.shape
    overwrite_a = overwrite_a or (_datanotshared(a1,a))
    geqrf, = get_lapack_funcs(('geqrf',),(a1,))
    if lwork is None or lwork == -1:
        # get optimal work array
        qr,tau,work,info = geqrf(a1,lwork=-1,overwrite_a=1)
        lwork = work[0]
    qr,tau,work,info = geqrf(a1,lwork=lwork,overwrite_a=overwrite_a)
    if info<0: raise ValueError,\
       'illegal value in %-th argument of internal geqrf'%(-info)
    gemm, = get_blas_funcs(('gemm',),(qr,))
    t = qr.dtype.char
    R = basic.triu(qr)
    Q = numpy.identity(M,dtype=t)
    ident = numpy.identity(M,dtype=t)
    zeros = numpy.zeros
    for i in range(min(M,N)):
        v = zeros((M,),t)
        v[i] = 1
        v[i+1:M] = qr[i+1:M,i]
        H = gemm(-tau[i],v,v,1+0j,ident,trans_b=2)
        Q = gemm(1,Q,H)
    return Q, R
Example #10
0
def hessenberg(a, calc_q=False, overwrite_a=False):
    """
    Compute Hessenberg form of a matrix.

    The Hessenberg decomposition is::

        A = Q H Q^H

    where `Q` is unitary/orthogonal and `H` has only zero elements below
    the first sub-diagonal.

    Parameters
    ----------
    a : ndarray
        Matrix to bring into Hessenberg form, of shape ``(M,M)``.
    calc_q : bool, optional
        Whether to compute the transformation matrix.  Default is False.
    overwrite_a : bool, optional
        Whether to overwrite `a`; may improve performance.
        Default is False.

    Returns
    -------
    H : ndarray
        Hessenberg form of `a`, of shape (M,M).
    Q : ndarray
        Unitary/orthogonal similarity transformation matrix ``A = Q H Q^H``.
        Only returned if ``calc_q=True``.  Of shape (M,M).

    """
    a1 = asarray(a)
    if len(a1.shape) != 2 or (a1.shape[0] != a1.shape[1]):
        raise ValueError('expected square matrix')
    overwrite_a = overwrite_a or (_datacopied(a1, a))
    gehrd,gebal = get_lapack_funcs(('gehrd','gebal'), (a1,))
    ba, lo, hi, pivscale, info = gebal(a1, permute=1, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal gebal '
                                                    '(hessenberg)' % -info)
    n = len(a1)
    lwork = calc_lwork.gehrd(gehrd.prefix, n, lo, hi)
    hq, tau, info = gehrd(ba, lo=lo, hi=hi, lwork=lwork, overwrite_a=1)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal gehrd '
                                        '(hessenberg)' % -info)

    if not calc_q:
        for i in range(lo, hi):
            hq[i+2:hi+1, i] = 0.0
        return hq

    # XXX: Use ORGHR routines to compute q.
    typecode = hq.dtype
    ger,gemm = get_blas_funcs(('ger','gemm'), dtype=typecode)
    q = None
    for i in range(lo, hi):
        if tau[i]==0.0:
            continue
        v = zeros(n, dtype=typecode)
        v[i+1] = 1.0
        v[i+2:hi+1] = hq[i+2:hi+1, i]
        hq[i+2:hi+1, i] = 0.0
        h = ger(-tau[i], v, v,a=diag(ones(n, dtype=typecode)), overwrite_a=1)
        if q is None:
            q = h
        else:
            q = gemm(1.0, q, h)
    if q is None:
        q = diag(ones(n, dtype=typecode))
    return hq, q
Example #11
0
def hessenberg(a, calc_q=False, overwrite_a=False):
    """Compute Hessenberg form of a matrix.

    The Hessenberg decomposition is

        A = Q H Q^H

    where Q is unitary/orthogonal and H has only zero elements below the first
    subdiagonal.

    Parameters
    ----------
    a : array, shape (M,M)
        Matrix to bring into Hessenberg form
    calc_q : boolean
        Whether to compute the transformation matrix
    overwrite_a : boolean
        Whether to ovewrite data in a (may improve performance)

    Returns
    -------
    H : array, shape (M,M)
        Hessenberg form of A

    (If calc_q == True)
    Q : array, shape (M,M)
        Unitary/orthogonal similarity transformation matrix s.t. A = Q H Q^H

    """
    a1 = asarray(a)
    if len(a1.shape) != 2 or (a1.shape[0] != a1.shape[1]):
        raise ValueError("expected square matrix")
    overwrite_a = overwrite_a or (_datacopied(a1, a))
    gehrd, gebal = get_lapack_funcs(("gehrd", "gebal"), (a1,))
    ba, lo, hi, pivscale, info = gebal(a1, permute=1, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError("illegal value in %d-th argument of internal gebal " "(hessenberg)" % -info)
    n = len(a1)
    lwork = calc_lwork.gehrd(gehrd.prefix, n, lo, hi)
    hq, tau, info = gehrd(ba, lo=lo, hi=hi, lwork=lwork, overwrite_a=1)
    if info < 0:
        raise ValueError("illegal value in %d-th argument of internal gehrd " "(hessenberg)" % -info)

    if not calc_q:
        for i in range(lo, hi):
            hq[i + 2 : hi + 1, i] = 0.0
        return hq

    # XXX: Use ORGHR routines to compute q.
    typecode = hq.dtype
    ger, gemm = get_blas_funcs(("ger", "gemm"), dtype=typecode)
    q = None
    for i in range(lo, hi):
        if tau[i] == 0.0:
            continue
        v = zeros(n, dtype=typecode)
        v[i + 1] = 1.0
        v[i + 2 : hi + 1] = hq[i + 2 : hi + 1, i]
        hq[i + 2 : hi + 1, i] = 0.0
        h = ger(-tau[i], v, v, a=diag(ones(n, dtype=typecode)), overwrite_a=1)
        if q is None:
            q = h
        else:
            q = gemm(1.0, q, h)
    if q is None:
        q = diag(ones(n, dtype=typecode))
    return hq, q
Example #12
0
 def check_blas(self):
     a = array([[1,1,1]])
     b = array([[1],[1],[1]])
     gemm, = get_blas_funcs(('gemm',),(a,b))
     assert_array_almost_equal(gemm(1,a,b),[[3]],15)
Example #13
0
def hessenberg(a, calc_q=False, overwrite_a=False):
    """Compute Hessenberg form of a matrix.

    The Hessenberg decomposition is

        A = Q H Q^H

    where Q is unitary/orthogonal and H has only zero elements below the first
    subdiagonal.

    Parameters
    ----------
    a : array, shape (M,M)
        Matrix to bring into Hessenberg form
    calc_q : boolean
        Whether to compute the transformation matrix
    overwrite_a : boolean
        Whether to ovewrite data in a (may improve performance)

    Returns
    -------
    H : array, shape (M,M)
        Hessenberg form of A

    (If calc_q == True)
    Q : array, shape (M,M)
        Unitary/orthogonal similarity transformation matrix s.t. A = Q H Q^H

    """
    a1 = asarray(a)
    if len(a1.shape) != 2 or (a1.shape[0] != a1.shape[1]):
        raise ValueError('expected square matrix')
    overwrite_a = overwrite_a or (_datacopied(a1, a))
    gehrd, gebal = get_lapack_funcs(('gehrd', 'gebal'), (a1, ))
    ba, lo, hi, pivscale, info = gebal(a1, permute=1, overwrite_a=overwrite_a)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal gebal '
                         '(hessenberg)' % -info)
    n = len(a1)
    lwork = calc_lwork.gehrd(gehrd.prefix, n, lo, hi)
    hq, tau, info = gehrd(ba, lo=lo, hi=hi, lwork=lwork, overwrite_a=1)
    if info < 0:
        raise ValueError('illegal value in %d-th argument of internal gehrd '
                         '(hessenberg)' % -info)

    if not calc_q:
        for i in range(lo, hi):
            hq[i + 2:hi + 1, i] = 0.0
        return hq

    # XXX: Use ORGHR routines to compute q.
    ger, gemm = get_blas_funcs(('ger', 'gemm'), (hq, ))
    typecode = hq.dtype.char
    q = None
    for i in range(lo, hi):
        if tau[i] == 0.0:
            continue
        v = zeros(n, dtype=typecode)
        v[i + 1] = 1.0
        v[i + 2:hi + 1] = hq[i + 2:hi + 1, i]
        hq[i + 2:hi + 1, i] = 0.0
        h = ger(-tau[i], v, v, a=diag(ones(n, dtype=typecode)), overwrite_a=1)
        if q is None:
            q = h
        else:
            q = gemm(1.0, q, h)
    if q is None:
        q = diag(ones(n, dtype=typecode))
    return hq, q