2020-07-30 15:11:09 +02:00
|
|
|
|
! Wrapper around LAPACK’s dgges (generalized Schur decomposition) that gives a
|
|
|
|
|
! better access to error conditions than does MATLAB’s qz.
|
|
|
|
|
!
|
|
|
|
|
! Syntax:
|
|
|
|
|
! [ss, tt, zz, sdim, eigval, info] = mjdgges(e, d, qz_criterium, zhreshold)
|
|
|
|
|
!
|
|
|
|
|
! Inputs:
|
|
|
|
|
! e [double] real square (n×n) matrix
|
|
|
|
|
! d [double] real square (n×n) matrix
|
|
|
|
|
! qz_criterium [double] scalar (of the form 1+ε)
|
|
|
|
|
! zhreshold [double] used for detecting eigenvalues too close to 0÷0
|
|
|
|
|
!
|
|
|
|
|
! Outputs:
|
|
|
|
|
! ss [double] (n×n) quasi-triangular matrix
|
|
|
|
|
! tt [double] (n×n) quasi-triangular matrix
|
|
|
|
|
! zz [double] (n×n) orthogonal matrix
|
|
|
|
|
! sdim [integer] scalar, number of stable eigenvalues
|
|
|
|
|
! eigval [complex] (n×1) vector of generalized eigenvalues
|
|
|
|
|
! info [integer] scalar, error code of dgges (or 30 if eigenvalue close to 0÷0)
|
|
|
|
|
|
2023-04-14 14:21:01 +02:00
|
|
|
|
! Copyright © 2006-2023 Dynare Team
|
2020-01-08 18:36:17 +01:00
|
|
|
|
!
|
|
|
|
|
! This file is part of Dynare.
|
|
|
|
|
!
|
|
|
|
|
! Dynare is free software: you can redistribute it and/or modify
|
|
|
|
|
! it under the terms of the GNU General Public License as published by
|
|
|
|
|
! the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
! (at your option) any later version.
|
|
|
|
|
!
|
|
|
|
|
! Dynare is distributed in the hope that it will be useful,
|
|
|
|
|
! but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
! GNU General Public License for more details.
|
|
|
|
|
!
|
|
|
|
|
! You should have received a copy of the GNU General Public License
|
2021-06-09 17:33:48 +02:00
|
|
|
|
! along with Dynare. If not, see <https://www.gnu.org/licenses/>.
|
2020-01-08 18:36:17 +01:00
|
|
|
|
|
|
|
|
|
#include "defines.F08"
|
|
|
|
|
|
|
|
|
|
module select_fct_mod
|
|
|
|
|
use iso_fortran_env
|
2023-04-14 14:21:01 +02:00
|
|
|
|
implicit none (type, external)
|
2020-01-08 18:36:17 +01:00
|
|
|
|
|
|
|
|
|
real(real64) :: criterium
|
|
|
|
|
contains
|
|
|
|
|
logical(bllog) function select_fct(alpha_r, alpha_i, beta)
|
|
|
|
|
use blas
|
|
|
|
|
|
|
|
|
|
real(real64), intent(in) :: alpha_r, alpha_i, beta
|
|
|
|
|
|
|
|
|
|
select_fct = alpha_r**2 + alpha_i**2 < criterium**2 * beta**2
|
|
|
|
|
end function select_fct
|
|
|
|
|
end module select_fct_mod
|
|
|
|
|
|
|
|
|
|
subroutine mexFunction(nlhs, plhs, nrhs, prhs) bind(c, name='mexFunction')
|
|
|
|
|
use iso_fortran_env
|
|
|
|
|
use iso_c_binding
|
|
|
|
|
use select_fct_mod
|
|
|
|
|
use matlab_mex
|
|
|
|
|
use lapack
|
2023-04-14 14:21:01 +02:00
|
|
|
|
implicit none (type, external)
|
2020-01-08 18:36:17 +01:00
|
|
|
|
|
|
|
|
|
type(c_ptr), dimension(*), intent(in), target :: prhs
|
|
|
|
|
type(c_ptr), dimension(*), intent(out) :: plhs
|
|
|
|
|
integer(c_int), intent(in), value :: nlhs, nrhs
|
|
|
|
|
|
2020-07-30 15:11:09 +02:00
|
|
|
|
integer(c_size_t) :: n
|
2020-01-08 18:36:17 +01:00
|
|
|
|
real(real64) :: zhreshold
|
|
|
|
|
integer(blint) :: n_bl, lwork, info_bl, sdim_bl
|
|
|
|
|
real(real64), dimension(:), allocatable :: alpha_r, alpha_i, beta, work
|
|
|
|
|
logical(bllog), dimension(:), allocatable :: bwork
|
2021-06-03 19:00:09 +02:00
|
|
|
|
! The pointers used in the LAPACK call are marked as contiguous, to
|
|
|
|
|
! avoid temporary copies beforehand.
|
|
|
|
|
real(real64), dimension(:), pointer, contiguous :: s, t, z, info, sdim, vsl
|
2020-01-08 18:36:17 +01:00
|
|
|
|
#if MX_HAS_INTERLEAVED_COMPLEX
|
|
|
|
|
complex(real64), dimension(:), pointer :: gev
|
|
|
|
|
#else
|
|
|
|
|
real(real64), dimension(:), pointer :: gev_r, gev_i
|
|
|
|
|
#endif
|
|
|
|
|
|
2020-01-10 17:55:57 +01:00
|
|
|
|
if (nrhs < 2 .or. nrhs > 4 .or. nlhs /= 6) then
|
|
|
|
|
call mexErrMsgTxt("MJDGGES: takes 2, 3 or 4 input arguments and exactly 6 output arguments.")
|
2020-01-08 18:36:17 +01:00
|
|
|
|
end if
|
|
|
|
|
|
2020-07-30 15:11:09 +02:00
|
|
|
|
n = mxGetM(prhs(1))
|
2022-03-18 18:18:24 +01:00
|
|
|
|
if (.not. mxIsDouble(prhs(1)) .or. mxIsComplex(prhs(1)) .or. mxIsSparse(prhs(1)) &
|
|
|
|
|
.or. .not. mxIsDouble(prhs(2)) .or. mxIsComplex(prhs(2)) .or. mxIsSparse(prhs(2)) &
|
2020-07-30 15:11:09 +02:00
|
|
|
|
.or. mxGetN(prhs(1)) /= n .or. mxGetM(prhs(2)) /= n .or. mxGetN(prhs(2)) /= n) then
|
2022-03-18 18:18:24 +01:00
|
|
|
|
call mexErrMsgTxt("MJDGGES: first two arguments should be real dense matrices of the same dimension")
|
2020-01-08 18:36:17 +01:00
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
! Set criterium for stable eigenvalues
|
|
|
|
|
if (nrhs >= 3 .and. mxGetM(prhs(3)) > 0) then
|
2020-07-30 15:11:09 +02:00
|
|
|
|
if (.not. (mxIsScalar(prhs(3)) .and. mxIsNumeric(prhs(3)))) then
|
|
|
|
|
call mexErrMsgTxt("MJDGGES: third argument (qz_criterium) should be a numeric scalar")
|
|
|
|
|
end if
|
|
|
|
|
criterium = mxGetScalar(prhs(3))
|
2020-01-08 18:36:17 +01:00
|
|
|
|
else
|
|
|
|
|
criterium = 1_real64 + 1e-6_real64
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
! set criterium for 0/0 generalized eigenvalues */
|
|
|
|
|
if (nrhs == 4 .and. mxGetM(prhs(4)) > 0) then
|
2020-07-30 15:11:09 +02:00
|
|
|
|
if (.not. (mxIsScalar(prhs(4)) .and. mxIsNumeric(prhs(4)))) then
|
|
|
|
|
call mexErrMsgTxt("MJDGGES: fourth argument (zhreshold) should be a numeric scalar")
|
|
|
|
|
end if
|
|
|
|
|
zhreshold = mxGetScalar(prhs(4))
|
2020-01-08 18:36:17 +01:00
|
|
|
|
else
|
|
|
|
|
zhreshold = 1e-6_real64
|
|
|
|
|
end if
|
|
|
|
|
|
2020-07-30 15:11:09 +02:00
|
|
|
|
plhs(1) = mxCreateDoubleMatrix(n, n, mxREAL)
|
|
|
|
|
plhs(2) = mxCreateDoubleMatrix(n, n, mxREAL)
|
|
|
|
|
plhs(3) = mxCreateDoubleMatrix(n, n, mxREAL)
|
2020-01-10 17:55:57 +01:00
|
|
|
|
plhs(4) = mxCreateDoubleMatrix(1_mwSize, 1_mwSize, mxREAL)
|
2020-07-30 15:11:09 +02:00
|
|
|
|
plhs(5) = mxCreateDoubleMatrix(n, 1_mwSize, mxCOMPLEX)
|
2020-01-10 17:55:57 +01:00
|
|
|
|
plhs(6) = mxCreateDoubleMatrix(1_mwSize, 1_mwSize, mxREAL)
|
|
|
|
|
|
|
|
|
|
s => mxGetPr(plhs(1))
|
|
|
|
|
t => mxGetPr(plhs(2))
|
|
|
|
|
sdim => mxGetPr(plhs(4))
|
2020-01-08 18:36:17 +01:00
|
|
|
|
#if MX_HAS_INTERLEAVED_COMPLEX
|
2020-01-10 17:55:57 +01:00
|
|
|
|
gev => mxGetComplexDoubles(plhs(5))
|
2020-01-08 18:36:17 +01:00
|
|
|
|
#else
|
2020-01-10 17:55:57 +01:00
|
|
|
|
gev_r => mxGetPr(plhs(5))
|
|
|
|
|
gev_i => mxGetPi(plhs(5))
|
2020-01-08 18:36:17 +01:00
|
|
|
|
#endif
|
2020-01-10 17:55:57 +01:00
|
|
|
|
info => mxGetPr(plhs(6))
|
|
|
|
|
z => mxGetPr(plhs(3))
|
2020-01-08 18:36:17 +01:00
|
|
|
|
vsl => null()
|
|
|
|
|
|
|
|
|
|
! Copy input matrices, since we can’t modify them
|
|
|
|
|
associate (a => mxGetPr(prhs(1)), b => mxGetPr(prhs(2)))
|
|
|
|
|
s = a
|
|
|
|
|
t = b
|
|
|
|
|
end associate
|
|
|
|
|
|
2020-07-30 15:11:09 +02:00
|
|
|
|
n_bl = int(n, blint)
|
2020-01-08 18:36:17 +01:00
|
|
|
|
lwork = 16*n_bl + 16
|
|
|
|
|
allocate(alpha_r(n_bl), alpha_i(n_bl), beta(n_bl), bwork(n_bl), work(lwork))
|
|
|
|
|
|
|
|
|
|
call dgges("N", "V", "S", select_fct, n_bl, s, n_bl, t, n_bl, sdim_bl, &
|
|
|
|
|
alpha_r, alpha_i, beta, vsl, n_bl, z, n_bl, work, lwork, bwork, info_bl)
|
|
|
|
|
|
|
|
|
|
info = info_bl
|
|
|
|
|
sdim = sdim_bl
|
|
|
|
|
|
|
|
|
|
#if MX_HAS_INTERLEAVED_COMPLEX
|
|
|
|
|
where (alpha_i == 0_real64 .and. beta == 0_real64)
|
|
|
|
|
gev = alpha_r / beta
|
|
|
|
|
elsewhere
|
|
|
|
|
gev = cmplx(alpha_r, alpha_i, real64) / beta
|
|
|
|
|
end where
|
|
|
|
|
#else
|
|
|
|
|
gev_r = alpha_r / beta
|
|
|
|
|
where (alpha_i == 0_real64 .and. beta == 0_real64)
|
|
|
|
|
gev_i = 0_real64
|
|
|
|
|
elsewhere
|
|
|
|
|
gev_i = alpha_i / beta
|
|
|
|
|
end where
|
|
|
|
|
#endif
|
|
|
|
|
|
|
|
|
|
! If the ratio of some eigenvalue is too close to 0/0, return specific
|
|
|
|
|
! error number (only if no other error)
|
|
|
|
|
if (any(abs(alpha_r) <= zhreshold .and. abs(beta) <= zhreshold) .and. info_bl == 0) &
|
|
|
|
|
info = 30
|
|
|
|
|
end subroutine mexFunction
|