diff --git a/example/linalg/example_repmat.f90 b/example/linalg/example_repmat.f90 new file mode 100644 index 000000000..c907ec879 --- /dev/null +++ b/example/linalg/example_repmat.f90 @@ -0,0 +1,12 @@ +program example_repmat + use stdlib_linalg, only: repmat + implicit none + real, allocatable :: a(:, :),b(:,:) + a = reshape([1., 2., 3., 4.],[2, 2],order=[2, 1]) + b = repmat(a, 2, 2) +! A = reshape([1., 2., 1., 2.,& +! 3., 4., 3., 4.,& +! 1., 2., 1., 2.,& +! 3., 4., 3., 4.,& +! ], [4, 4],order=[2, 1]) +end program example_repmat diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 0fb95a2d3..a056e791b 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -22,6 +22,7 @@ set(fppFiles stdlib_linalg.fypp stdlib_linalg_diag.fypp stdlib_linalg_outer_product.fypp + stdlib_linalg_repmat.fypp stdlib_optval.fypp stdlib_selection.fypp stdlib_sorting.fypp diff --git a/src/stdlib_linalg.fypp b/src/stdlib_linalg.fypp index bc1017f0a..d064c948e 100644 --- a/src/stdlib_linalg.fypp +++ b/src/stdlib_linalg.fypp @@ -14,6 +14,7 @@ module stdlib_linalg public :: eye public :: trace public :: outer_product + public :: repmat public :: is_square public :: is_diagonal public :: is_symmetric @@ -92,6 +93,21 @@ module stdlib_linalg #:endfor end interface outer_product + ! repeat matrix (of 2d array) + interface repmat + !! version: experimental + !! + !! Creates large matrices from a small array, `repmat()` repeats the given values of the array to create the large matrix. + !! ([Specification](../page/specs/stdlib_linalg.html# + !! repmat-creates-large-matrices-from-a-small-array)) + #:for k1, t1 in RCI_KINDS_TYPES + pure module function repmat_${t1[0]}$${k1}$(a,m,n) result(res) + ${t1}$, intent(in) :: a(:,:) + integer, intent(in) :: m,n + ${t1}$ :: res(m*size(a,1),n*size(a,2)) + end function repmat_${t1[0]}$${k1}$ + #:endfor + end interface repmat ! Check for squareness interface is_square diff --git a/src/stdlib_linalg_repmat.fypp b/src/stdlib_linalg_repmat.fypp new file mode 100644 index 000000000..3ea47a064 --- /dev/null +++ b/src/stdlib_linalg_repmat.fypp @@ -0,0 +1,30 @@ +#:include "common.fypp" +#:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES +submodule (stdlib_linalg) stdlib_linalg_repmat + + implicit none + +contains + + #:for k1, t1 in RCI_KINDS_TYPES + pure module function repmat_${t1[0]}$${k1}$(a, m, n) result(res) + ${t1}$, intent(in) :: a(:,:) + integer, intent(in) :: m,n + ${t1}$ :: res(m*size(a,1),n*size(a,2)) + integer ::i,j,k,l + associate(ma=>size(a,1),na=>size(a,2)) + do j=1,n + do l=1,na + do i=1,m + do k=1,ma + res((i-1)*ma+k,(j-1)*na+l)=a(k,l) + end do + end do + end do + end do + end associate + end function repmat_${t1[0]}$${k1}$ + + #:endfor + +end submodule diff --git a/test/linalg/test_linalg.fypp b/test/linalg/test_linalg.fypp index f74cbff6b..f278345da 100644 --- a/test/linalg/test_linalg.fypp +++ b/test/linalg/test_linalg.fypp @@ -3,7 +3,7 @@ module test_linalg use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64 - use stdlib_linalg, only: diag, eye, trace, outer_product + use stdlib_linalg, only: diag, eye, trace, outer_product, repmat implicit none @@ -57,7 +57,17 @@ contains new_unittest("outer_product_int8", test_outer_product_int8), & new_unittest("outer_product_int16", test_outer_product_int16), & new_unittest("outer_product_int32", test_outer_product_int32), & - new_unittest("outer_product_int64", test_outer_product_int64) & + new_unittest("outer_product_int64", test_outer_product_int64), & + new_unittest("test_repmat_rsp",test_repmat_rsp), & + new_unittest("test_repmat_rdp",test_repmat_rdp), & + new_unittest("test_repmat_rqp",test_repmat_rqp), & + new_unittest("test_repmat_csp",test_repmat_csp), & + new_unittest("test_repmat_cdp",test_repmat_cdp), & + new_unittest("test_repmat_cqp",test_repmat_cqp), & + new_unittest("test_repmat_int8",test_repmat_int8), & + new_unittest("test_repmat_int16",test_repmat_int16), & + new_unittest("test_repmat_int32",test_repmat_int32), & + new_unittest("test_repmat_int64",test_repmat_int64) & ] end subroutine collect_linalg @@ -703,6 +713,197 @@ contains end subroutine test_outer_product_int64 + subroutine test_repmat_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error +#:if WITH_QP + integer, parameter :: n = 2 + real(qp) :: a(n,n) + real(qp),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") +#:else + call skip_test(error, "Quadruple precision is not enabled") +#:endif + end subroutine test_repmat_rqp + subroutine test_repmat_cqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error +#:if WITH_QP + integer, parameter :: n = 2 + complex(qp) :: a(n,n) + complex(qp),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") +#:else + call skip_test(error, "Quadruple precision is not enabled") +#:endif + end subroutine test_repmat_cqp + + + subroutine test_repmat_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + real(sp) :: a(n,n) + real(sp),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_rsp + + subroutine test_repmat_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + real(dp) :: a(n,n) + real(dp),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_rdp + + + subroutine test_repmat_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + complex(sp) :: a(n,n) + complex(sp),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_csp + + subroutine test_repmat_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + complex(dp) :: a(n,n) + complex(dp),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_cdp + + subroutine test_repmat_int8(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + integer(int8) :: a(n,n) + integer(int8),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_int8 + + subroutine test_repmat_int16(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + integer(int16) :: a(n,n) + integer(int16),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_int16 + + subroutine test_repmat_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + integer(int32) :: a(n,n) + integer(int32),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_int32 + + subroutine test_repmat_int64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 2 + integer(int64) :: a(n,n) + integer(int64),allocatable:: expected(:,:),diff(:,:) + + a=reshape([1,2,3,4],shape(a),order=[2,1]) + expected = reshape([& + 1,2,1,2,& + 3,4,3,4,& + 1,2,1,2,& + 3,4,3,4 ],[4,4],order=[2,1]) + diff = expected - repmat(a, 2, 2) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_repmat_int64 + + + pure recursive function catalan_number(n) result(value) integer, intent(in) :: n integer :: value pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy