Merge pull request https://github.com/fortran-lang/fpm/pull/233 from awvwgk/link

Allow linking against external libraries

4 files changed, 152 insertions, 0 deletions

diff --git a/example_packages/link_external/.gitignore b/example_packages/link_external/.gitignore
new file mode 100644
index 0000000..a007fea
--- /dev/null
+++ b/example_packages/link_external/.gitignore
@@ -0,0 +1 @@
+build/*
diff --git a/example_packages/link_external/app/main.f90 b/example_packages/link_external/app/main.f90
new file mode 100644
index 0000000..8df408d
--- /dev/null
+++ b/example_packages/link_external/app/main.f90
@@ -0,0 +1,21 @@
+program test_blas
+   use wrapped_gemv, only : sp, gemv
+   implicit none
+
+   integer :: i, j
+   real(sp) :: mat(4, 4), vec(4), res(4)
+
+   do i = 1, size(vec)
+      vec(i) = sqrt(real(i, sp))
+   end do
+
+   do i = 1, size(mat, 2)
+      do j = 1, size(mat, 1)
+         mat(j, i) = sqrt(real(j * i, sp))
+      end do
+   end do
+
+   call gemv(mat, vec, res, alpha=-1.0_sp, trans='t')
+
+end program test_blas
+
diff --git a/example_packages/link_external/fpm.toml b/example_packages/link_external/fpm.toml
new file mode 100644
index 0000000..f2eafa2
--- /dev/null
+++ b/example_packages/link_external/fpm.toml
@@ -0,0 +1,4 @@
+name = "link_external"
+
+[build]
+link = "blas"
diff --git a/example_packages/link_external/src/wrapped_gemv.f90 b/example_packages/link_external/src/wrapped_gemv.f90
new file mode 100644
index 0000000..5ff1d7c
--- /dev/null
+++ b/example_packages/link_external/src/wrapped_gemv.f90
@@ -0,0 +1,126 @@
+!> Performs one of the matrix-vector operations
+!>
+!>    y := alpha*A*x + beta*y,   or   y := alpha*A**T*x + beta*y,
+!>
+!> where alpha and beta are scalars, x and y are vectors and A is an
+!> m by n matrix.
+module wrapped_gemv
+  implicit none
+  private
+
+  public :: sp, dp, gemv
+
+  integer, parameter :: sp = selected_real_kind(6)
+  integer, parameter :: dp = selected_real_kind(15)
+
+
+  interface gemv
+    module procedure :: wrap_sgemv
+    module procedure :: wrap_dgemv
+  end interface gemv
+
+
+  interface blas_gemv
+    subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
+      import :: sp
+      real(sp), intent(in) :: a(lda, *)
+      real(sp), intent(in) :: x(*)
+      real(sp), intent(inout) :: y(*)
+      real(sp), intent(in) :: alpha
+      real(sp), intent(in) :: beta
+      character(len=1), intent(in) :: trans
+      integer, intent(in) :: incx
+      integer, intent(in) :: incy
+      integer, intent(in) :: m
+      integer, intent(in) :: n
+      integer, intent(in) :: lda
+    end subroutine sgemv
+    subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
+      import :: dp
+      real(dp), intent(in) :: a(lda, *)
+      real(dp), intent(in) :: x(*)
+      real(dp), intent(inout) :: y(*)
+      real(dp), intent(in) :: alpha
+      real(dp), intent(in) :: beta
+      character(len=1), intent(in) :: trans
+      integer, intent(in) :: incx
+      integer, intent(in) :: incy
+      integer, intent(in) :: m
+      integer, intent(in) :: n
+      integer, intent(in) :: lda
+    end subroutine dgemv
+  end interface blas_gemv
+
+
+contains
+
+
+  subroutine wrap_sgemv(amat, xvec, yvec, alpha, beta, trans)
+    real(sp), intent(in) :: amat(:, :)
+    real(sp), intent(in) :: xvec(:)
+    real(sp), intent(inout) :: yvec(:)
+    real(sp), intent(in), optional :: alpha
+    real(sp), intent(in), optional :: beta
+    character(len=1), intent(in), optional :: trans
+    real(sp) :: a, b
+    character(len=1) :: tra
+    integer :: incx, incy, m, n, lda
+    if (present(alpha)) then
+      a = alpha
+    else
+      a = 1.0_sp
+    end if
+    if (present(beta)) then
+      b = beta
+    else
+      b = 0
+    end if
+    if (present(trans)) then
+      tra = trans
+    else
+      tra = 'n'
+    end if
+    incx = 1
+    incy = 1
+    lda = max(1, size(amat, 1))
+    m = size(amat, 1)
+    n = size(amat, 2)
+    call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy)
+  end subroutine wrap_sgemv
+
+
+  subroutine wrap_dgemv(amat, xvec, yvec, alpha, beta, trans)
+    real(dp), intent(in) :: amat(:, :)
+    real(dp), intent(in) :: xvec(:)
+    real(dp), intent(inout) :: yvec(:)
+    real(dp), intent(in), optional :: alpha
+    real(dp), intent(in), optional :: beta
+    character(len=1), intent(in), optional :: trans
+    real(dp) :: a, b
+    character(len=1) :: tra
+    integer :: incx, incy, m, n, lda
+    if (present(alpha)) then
+      a = alpha
+    else
+      a = 1.0_dp
+    end if
+    if (present(beta)) then
+      b = beta
+    else
+      b = 0
+    end if
+    if (present(trans)) then
+      tra = trans
+    else
+      tra = 'n'
+    end if
+    incx = 1
+    incy = 1
+    lda = max(1, size(amat, 1))
+    m = size(amat, 1)
+    n = size(amat, 2)
+    call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy)
+  end subroutine wrap_dgemv
+
+
+end module wrapped_gemv