243 lines
8.6 KiB
Plaintext
243 lines
8.6 KiB
Plaintext
! Copyright © 2019-2023 Dynare Team
|
|
!
|
|
! 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
|
|
! along with Dynare. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
module blas
|
|
use iso_fortran_env
|
|
implicit none (type, external)
|
|
|
|
#if defined(MATLAB_MEX_FILE) && __SIZEOF_POINTER__ == 8
|
|
integer, parameter :: blint = int64
|
|
integer, parameter :: bllog = 8 ! Logical kind, gfortran-specific
|
|
#else
|
|
integer, parameter :: blint = int32
|
|
integer, parameter :: bllog = 4 ! Logical kind, gfortran-specific
|
|
#endif
|
|
|
|
interface
|
|
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
|
|
import :: blint, real64
|
|
implicit none
|
|
character, intent(in) :: transa, transb
|
|
integer(blint), intent(in) :: m, n, k, lda, ldb, ldc
|
|
real(real64), dimension(*), intent(in) :: a, b
|
|
real(real64), intent(in) :: alpha, beta
|
|
real(real64), dimension(*), intent(inout) :: c
|
|
end subroutine dgemm
|
|
|
|
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
|
|
import :: blint, real64
|
|
implicit none
|
|
character, intent(in) :: trans
|
|
integer(blint), intent(in) :: m, n, lda, incx, incy
|
|
real(real64), dimension(*), intent(in) :: a, x
|
|
real(real64), intent(in) :: alpha, beta
|
|
real(real64), dimension(*), intent(inout) :: y
|
|
end subroutine dgemv
|
|
end interface
|
|
|
|
contains
|
|
|
|
! Updating a matrix using blas DGEMM
|
|
! C <- alpha*op(A)*op(B) + beta*C
|
|
subroutine matmul_add(opA, opB, alpha, A, B, beta, C)
|
|
character, intent(in) :: opA, opB
|
|
real(real64), dimension(:,:), intent(in) :: A, B
|
|
real(real64), dimension(:,:), intent(inout) :: C
|
|
real(real64), intent(in) :: alpha, beta
|
|
integer(blint) :: m, n, k, lda, ldb
|
|
if (opA == "N") then
|
|
m = int(size(A,1), blint)
|
|
k = int(size(A,2), blint)
|
|
lda = m
|
|
else
|
|
m = int(size(A,2), blint)
|
|
k = int(size(A,1), blint)
|
|
lda = k
|
|
end if
|
|
if (opB == "N") then
|
|
n = int(size(B,2), blint)
|
|
ldb = k
|
|
else
|
|
n = int(size(B,1), blint)
|
|
ldb = n
|
|
end if
|
|
#ifdef DEBUG
|
|
if ( (opA /= "N") .and. (opA /= "T") .and. (opA /= "C") ) then
|
|
print *, "opA must be either N, T or C"
|
|
end if
|
|
if ( (opB /= "N") .and. (opB /= "T") .and. (opB /= "C") ) then
|
|
print *, "opB must be either N, T or C"
|
|
end if
|
|
if (((opA == "N") .and. (opB == "N") .and. (size(A,2) /= size(B,1))) .or.&
|
|
&((opA == "N") .and. (opB /= "N") .and. (size(A,2) /= size(B,2))) .or.&
|
|
&((opA /= "N") .and. (opB == "N") .and. (size(A,1) /= size(B,1))) .or.&
|
|
&((opA /= "N") .and. (opB /= "N") .and. (size(A,1) /= size(B,2)))) &
|
|
then
|
|
print *, "Inconsistent number of columns of op(A) and number of rows &
|
|
&of op(B)"
|
|
end if
|
|
if (m /= size(C,1)) then
|
|
print *, "Inconsistent number of rows of op(A) and number of rows &
|
|
&of C"
|
|
end if
|
|
#endif
|
|
call dgemm(opA, opB, m, n, k, alpha, A, lda, B, &
|
|
ldb, beta, C, m)
|
|
end subroutine
|
|
|
|
end module blas
|
|
|
|
module lapack
|
|
use blas
|
|
implicit none (type, external)
|
|
|
|
interface
|
|
subroutine dgelsd(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, iwork, info)
|
|
import :: blint, real64
|
|
implicit none
|
|
integer(blint), intent(in) :: m, n, nrhs, lda, ldb, lwork
|
|
real(real64), dimension(*), intent(inout) :: a, b
|
|
real(real64), dimension(*), intent(out) :: s, work
|
|
real(real64), intent(in) :: rcond
|
|
integer(blint), dimension(*), intent(out) :: iwork
|
|
integer(blint), intent(out) :: rank, info
|
|
end subroutine dgelsd
|
|
|
|
subroutine dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
|
|
import :: blint, real64
|
|
implicit none
|
|
integer(blint), intent(in) :: n, nrhs, lda, ldb
|
|
real(real64), dimension(*), intent(inout) :: a, b
|
|
integer(blint), dimension(*), intent(out) :: ipiv
|
|
integer(blint), intent(out) :: info
|
|
end subroutine dgesv
|
|
|
|
subroutine dgges(jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, sdim, &
|
|
alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, bwork, &
|
|
info)
|
|
import :: blint, bllog, real64
|
|
implicit none
|
|
character, intent(in) :: jobvsl, jobvsr, sort
|
|
interface
|
|
logical(bllog) function selctg(alphar, alphai, beta)
|
|
import :: bllog, real64
|
|
real(real64), intent(in) :: alphar, alphai, beta
|
|
end function selctg
|
|
end interface
|
|
integer(blint), intent(in) :: n, lda, ldb, ldvsl, ldvsr, lwork
|
|
real(real64), dimension(*), intent(inout) :: a, b
|
|
real(real64), dimension(*), intent(out) :: alphar, alphai, beta, vsl, vsr, work
|
|
logical(bllog), dimension(*), intent(out) :: bwork
|
|
integer(blint), intent(out) :: sdim, info
|
|
end subroutine dgges
|
|
|
|
subroutine dgecon(norm, n, a, lda, anorm, rcond, work, iwork, info)
|
|
import :: blint, real64
|
|
implicit none
|
|
character, intent(in) :: norm
|
|
integer(blint), intent(in) :: n, lda
|
|
real(real64), dimension(*), intent(in) :: a
|
|
real(real64), intent(in) :: anorm
|
|
real(real64), intent(out) :: rcond
|
|
real(real64), dimension(*), intent(out) :: work
|
|
integer(blint), dimension(*), intent(out) :: iwork
|
|
integer(blint), intent(out) :: info
|
|
end subroutine dgecon
|
|
|
|
subroutine dgetrf(m, n, a, lda, ipiv, info)
|
|
import :: blint, real64
|
|
implicit none
|
|
integer(blint), intent(in) :: m, n, lda
|
|
real(real64), dimension(*), intent(inout) :: a
|
|
integer(blint), dimension(*), intent(out) :: ipiv
|
|
integer(blint), intent(out) :: info
|
|
end subroutine dgetrf
|
|
|
|
subroutine dgetri(n, a, lda, ipiv, work, lwork, info)
|
|
import :: blint, real64
|
|
implicit none
|
|
integer(blint), intent(in) :: n, lda, lwork
|
|
real(real64), dimension(*), intent(inout) :: a
|
|
integer(blint), dimension(*), intent(in):: ipiv
|
|
real(real64), dimension(*), intent(out) :: work
|
|
integer(blint), intent(out) :: info
|
|
end subroutine dgetri
|
|
|
|
subroutine dpotrf(uplo, n, a, lda, info)
|
|
import :: blint, real64
|
|
implicit none
|
|
character, intent(in) :: uplo
|
|
integer(blint), intent(in) :: n, lda
|
|
real(real64), dimension(*), intent(inout) :: a
|
|
integer(blint), intent(out) :: info
|
|
end subroutine dpotrf
|
|
|
|
function dlange(norm, m, n, a, lda, work)
|
|
import :: blint, real64
|
|
implicit none
|
|
character, intent(in) :: norm
|
|
integer(blint), intent(in) :: m, n, lda
|
|
real(real64), dimension(*), intent(in) :: a
|
|
real(real64), dimension(*), intent(out) :: work
|
|
real(real64) :: dlange
|
|
end function dlange
|
|
|
|
function ilaenv(ispec, name, opts, n1, n2, n3, n4)
|
|
import :: blint
|
|
implicit none
|
|
integer(blint) :: ispec, n1, n2, n3, n4
|
|
character(len=*), intent(in) :: name, opts
|
|
integer(blint) :: ilaenv
|
|
end function ilaenv
|
|
end interface
|
|
|
|
contains
|
|
|
|
! Computing inv(A)*B using lapack DGESV
|
|
! B <- inv(A)*B
|
|
subroutine left_divide(A, B, ipiv, info)
|
|
real(real64), dimension(:,:), intent(inout) :: A
|
|
real(real64), dimension(:,:), intent(inout) :: B
|
|
integer(blint), dimension(:), intent(inout) :: ipiv
|
|
integer(blint), intent(inout) :: info
|
|
integer(blint) :: m, n
|
|
#ifdef DEBUG
|
|
if (size(ipiv) /= size(A,1)) then
|
|
print *, "Inconsistent number of rows of A and size of ipiv"
|
|
end if
|
|
if (size(A,2) /= size(B,1)) then
|
|
print *, "Inconsistent number of columns of A and number of rows of B"
|
|
end if
|
|
#endif
|
|
m = int(size(A,1), blint)
|
|
n = int(size(B,2), blint)
|
|
call dgesv(m, n, A, m, ipiv, B, m, info)
|
|
end subroutine left_divide
|
|
|
|
! Matlab-like norm function calling lapack DLANGE routine
|
|
real(real64) function norm(A, c)
|
|
real(real64), dimension(:,:), intent(in) :: A
|
|
character, intent(in) :: c
|
|
real(real64), dimension(:), allocatable :: work
|
|
integer(blint) :: nrow
|
|
nrow = int(size(A,1),blint)
|
|
norm = dlange(c, nrow, int(size(A,2), blint), &
|
|
&A, nrow, work)
|
|
end function norm
|
|
|
|
end module lapack
|