unmlq.cc (flens/lapack/interface/src/unmlq.cc)

      1
      2
      3
      4
      5
      6
      7
      8
      9
     10
     11
     12
     13
     14
     15
     16
     17
     18
     19
     20
     21
     22
     23
     24
     25
     26
     27
     28
     29
     30
     31
     32
     33
     34
     35
     36
     37
     38
     39
     40
     41
     42
     43
     44
     45
     46
     47
     48
     49
     50
     51
     52
     53
     54
     55
     56
     57
     58
     59
     60
     61
     62
     63
     64
     65
     66
     67
     68
     69
     70
     71
     72
     73
     74
     75
     76
     77
     78
     79
     80
     81
     82
     83
     84
     85
     86
     87
     88
     89
     90
     91
     92
     93
     94

#include <flens/lapack/interface/include/config.h>

namespace flens { namespace lapack {

extern "C" {

//-- zunmlq --------------------------------------------------------------------
void
LAPACK_DECL(zunmlq)(const char               *SIDE,
                    const char               *TRANS,
                    const INTEGER            *M,
                    const INTEGER            *N,
                    const INTEGER            *K,
                    DOUBLE_COMPLEX           *A,
                    const INTEGER            *LDA,
                    const DOUBLE_COMPLEX     *TAU,
                    DOUBLE_COMPLEX           *C,
                    const INTEGER            *LDC,
                    DOUBLE_COMPLEX           *WORK,
                    const INTEGER            *LWORK,
                    INTEGER                  *INFO)
{
    using std::max;
    using std::min;
//
//  Test the input parameters so that we pass LAPACK error checks
//
    *INFO = 0;
    const bool left   = (*SIDE=='L');
    const bool noTran = (*TRANS=='N');
    const bool lQuery = (*LWORK==-1);

    INTEGER nq, nw;

    if (left) {
        nq = *M;
        nw = *N;
    } else {
        nq = *N;
        nw = *M;
    }
    if (!left && *SIDE!='R') {
        *INFO = -1;
    } else if (!noTran && *TRANS!='C') {
        *INFO = -2;
    } else if (*M<0) {
        *INFO = -3;
    } else if (*N<0) {
        *INFO = -4;
    } else if (*K<0 || *K>nq) {
        *INFO = -5;
    } else if (*LDA<max(INTEGER(1), *K)) {
        *INFO = -7;
    } else if (*LDC<max(INTEGER(1), *M)) {
        *INFO = -10;
    } else if ((*LWORK<max(INTEGER(1), nw)) && (!lQuery)) {
        *INFO = -12;
    }
    if (*INFO!=0) {
        *INFO = -(*INFO);
        LAPACK_ERROR("ZUNMLQ", INFO);
        *INFO = -(*INFO);
        return;
    }
//
//  Handle worksize query
//
    if (lQuery) {
        // TODO: implement wsq
        ASSERT(0);
    }
//
//  Call FLENS implementation
//
    Side      side  = (*SIDE=='L') ? Left : Right;
    Transpose trans = (*TRANS=='N') ? NoTrans : ConjTrans;
    const INTEGER numColsA = (side==Left) ? *M : *N;

    auto zA         = reinterpret_cast<CXX_DOUBLE_COMPLEX *>(A);
    const auto zTAU = reinterpret_cast<const CXX_DOUBLE_COMPLEX *>(TAU);
    auto zC         = reinterpret_cast<CXX_DOUBLE_COMPLEX *>(C);
    auto zWORK      = reinterpret_cast<CXX_DOUBLE_COMPLEX *>(WORK);

    ZGeMatrixView          _A      = ZFSView(*K, numColsA, zA, *LDA);
    ZConstDenseVectorView  _TAU    = ZConstArrayView(*K, zTAU, 1);
    ZGeMatrixView          _C      = ZFSView(*M, *N, zC, *LDC);
    ZDenseVectorView       _WORK   = ZArrayView(*LWORK, zWORK, 1);

    unmlq(side, trans, _A, _TAU, _C, _WORK);
}

} // extern "C"

} } // namespace lapack, flens