From 9512a3eee89515002e1dd3f0992f7a302c59be17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Per=20=C3=96stlund?= Date: Wed, 4 Oct 2023 14:08:46 +0200 Subject: [PATCH] Add dhseqr to Lapack functions Fixes #11314 --- .../Compiler/NFFrontEnd/NFEvalFunction.mo | 1 + .../Compiler/NFFrontEnd/NFEvalFunctionExt.mo | 34 ++++++++++++++ OMCompiler/Compiler/Util/Lapack.mo | 23 ++++++++++ OMCompiler/Compiler/runtime/lapackimpl.c | 44 +++++++++++++++++++ 4 files changed, 102 insertions(+) diff --git a/OMCompiler/Compiler/NFFrontEnd/NFEvalFunction.mo b/OMCompiler/Compiler/NFFrontEnd/NFEvalFunction.mo index bc820ab4a1c..474d86982bf 100644 --- a/OMCompiler/Compiler/NFFrontEnd/NFEvalFunction.mo +++ b/OMCompiler/Compiler/NFFrontEnd/NFEvalFunction.mo @@ -1126,6 +1126,7 @@ algorithm case "dgetri" algorithm EvalFunctionExt.Lapack_dgetri(args); then (); case "dgeqpf" algorithm EvalFunctionExt.Lapack_dgeqpf(args); then (); case "dorgqr" algorithm EvalFunctionExt.Lapack_dorgqr(args); then (); + case "dhseqr" algorithm EvalFunctionExt.Lapack_dhseqr(args); then (); else fail(); end match; end evaluateExternal3; diff --git a/OMCompiler/Compiler/NFFrontEnd/NFEvalFunctionExt.mo b/OMCompiler/Compiler/NFFrontEnd/NFEvalFunctionExt.mo index 321bdbd893b..08746b38e11 100644 --- a/OMCompiler/Compiler/NFFrontEnd/NFEvalFunctionExt.mo +++ b/OMCompiler/Compiler/NFFrontEnd/NFEvalFunctionExt.mo @@ -495,6 +495,40 @@ algorithm assignVariable(info, Expression.makeInteger(INFO)); end Lapack_dorgqr; +function Lapack_dhseqr + input list args; +protected + Expression job, compz, n, ilo, ihi, h, ldh, wr, wi, z, ldz, work, lwork, info; + Integer N, ILO, IHI, LDH, LDZ, LWORK, INFO; + String JOB, COMPZ; + list> H, Z; + list WR, WI, WORK; +algorithm + {job, compz, n, ilo, ihi, h, ldh, wr, wi, z, ldz, work, lwork, info} := args; + + JOB := evaluateExtStringArg(job); + COMPZ := evaluateExtStringArg(compz); + N := evaluateExtIntArg(n); + ILO := evaluateExtIntArg(ilo); + IHI := evaluateExtIntArg(ihi); + H := evaluateExtRealMatrixArg(h); + LDH := evaluateExtIntArg(ldh); + Z := evaluateExtRealMatrixArg(z); + LDZ := evaluateExtIntArg(ldz); + WORK := evaluateExtRealArrayArg(work); + LWORK := evaluateExtIntArg(lwork); + + (H, WR, WI, Z, WORK, INFO) := + Lapack.dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, Z, LDZ, WORK, LWORK); + + assignVariableExt(h, Expression.makeRealMatrix(H)); + assignVariable(wr, Expression.makeRealArray(WR)); + assignVariable(wi, Expression.makeRealArray(WI)); + assignVariableExt(z, Expression.makeRealMatrix(Z)); + assignVariable(work, Expression.makeRealArray(WORK)); + assignVariable(info, Expression.makeInteger(INFO)); +end Lapack_dhseqr; + protected function evaluateExtIntArg input Expression arg; diff --git a/OMCompiler/Compiler/Util/Lapack.mo b/OMCompiler/Compiler/Util/Lapack.mo index 096abd37e7e..5a725c838ec 100644 --- a/OMCompiler/Compiler/Util/Lapack.mo +++ b/OMCompiler/Compiler/Util/Lapack.mo @@ -321,5 +321,28 @@ public function dorgqr outA, outWORK, outINFO) annotation(Library = {"omcruntime", "Lapack"}); end dorgqr; +public function dhseqr + input String inJOB; + input String inCOMPZ; + input Integer inN; + input Integer inILO; + input Integer inIHI; + input list> inH; + input Integer inLDH; + input list> inZ; + input Integer inLDZ; + input list inWORK; + input Integer inLWORK; + output list> outH; + output list outWR; + output list outWI; + output list> outZ; + output list outWORK; + output Integer outINFO; + external "C" LapackImpl__dhseqr(inJOB, inCOMPZ, inN, inILO, inIHI, inH, inLDH, + inZ, inLDZ, inWORK, inLWORK, outH, outWR, outWI, outZ, outWORK, outINFO) + annotation(Library = {"omcruntime", "Lapack"}); +end dhseqr; + annotation(__OpenModelica_Interface="util"); end Lapack; diff --git a/OMCompiler/Compiler/runtime/lapackimpl.c b/OMCompiler/Compiler/runtime/lapackimpl.c index 86170008b6d..8f3dff6c906 100644 --- a/OMCompiler/Compiler/runtime/lapackimpl.c +++ b/OMCompiler/Compiler/runtime/lapackimpl.c @@ -148,6 +148,10 @@ extern int dgetri_(integer *n, doublereal *a, integer *lda, integer *ipiv, extern int dorgqr_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); +extern int dhseqr_(const char *job, const 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); + static double* alloc_real_matrix(int N, int M, void *data) { double *matrix; @@ -867,6 +871,46 @@ void LapackImpl__dorgqr(int M, int N, int K, void *inA, int LDA, #endif } +void LapackImpl__dhseqr(const char *job, const char *compz, int N, int ILO, int IHI, + void **inH, int LDH, void **inZ, int LDZ, void **inWORK, int LWORK, + void **outH, void **WR, void **WI, void **outZ, void **outWORK, int *INFO) +{ +#ifdef HAVE_LAPACK + integer n, ilo, ihi, ldh, ldz, lwork, info = 0; + double *h, *z, *wr, *wi, *work; + + n = N; + ilo = ILO; + ihi = IHI; + ldh = LDH; + ldz = LDZ; + lwork = LWORK; + + h = alloc_real_matrix(ldh, n, inH); + z = alloc_real_matrix(ldz, n, inZ); + wr = alloc_zeroed_real_vector(n); + wi = alloc_zeroed_real_vector(n); + work = alloc_real_vector(lwork, inWORK); + + dhseqr_(job, compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info); + + *outH = mk_rml_real_matrix(ldh, n, h); + *WR = mk_rml_real_vector(n, wr); + *WI = mk_rml_real_vector(n, wi); + *outZ = mk_rml_real_matrix(ldz, n, z); + *outWORK = mk_rml_real_vector(lwork, work); + *INFO = info; + + free(h); + free(z); + free(wr); + free(wi); + free(work); +#else + OMC_NO_LAPACK_ERROR(); +#endif +} + #ifdef __cplusplus } #endif