Add dhseqr to Lapack functions

Fixes OpenModelica#11314
perost · Oct 4, 2023 · 9512a3e · 9512a3e
1 parent 36c233f
commit 9512a3e
Show file tree

Hide file tree

Showing 4 changed files with 102 additions and 0 deletions.
diff --git 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
@@ -495,6 +495,40 @@ algorithm
   assignVariable(info, Expression.makeInteger(INFO));
 end Lapack_dorgqr;
 
+function Lapack_dhseqr
+  input list<Expression> 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<list<Real>> H, Z;
+  list<Real> 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
@@ -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<list<Real>> inH;
+  input Integer inLDH;
+  input list<list<Real>> inZ;
+  input Integer inLDZ;
+  input list<Real> inWORK;
+  input Integer inLWORK;
+  output list<list<Real>> outH;
+  output list<Real> outWR;
+  output list<Real> outWI;
+  output list<list<Real>> outZ;
+  output list<Real> 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
@@ -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