Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • icon-libraries/libfortran-support
1 result
Show changes
Commits on Source (4)
Hide whitespace changes
Inline Side-by-side
AUTHORS.txt
View file @ 02329904
......@@ -12,6 +12,7 @@ Jonas Jucker
Leonidas Linardakis
Luis Kornblueh
Marek Jacob
Mikael Stellio
Monika Esch
Nathanael Huebbe
Pradipta Samanta
......
README.md
View file @ 02329904
......@@ -106,7 +106,7 @@ Please open a merge request and select one of our templates: __[feature/bugfix]_
## Contact
This repository is mainly maintained by the following maintainers:
- __Yen-Chen Chen__ (yen-chen.chen@kit.edu)
- __Jonas Jucker__ (jonas.jucker@env.ethz.ch)
- __Mikael Stellio__ (mikael.stellio@c2sm.ethz.ch)
- __Will Sawyer__ (william.sawyer@cscs.ch)
This repository is owned by the `icon-libraries` group, contacts about general ICON library questions:
......
cmake/gtest_helper.cmake
View file @ 02329904
......@@ -31,7 +31,7 @@ function(fs_add_c_test test_name)
add_executable("CTest_${test_name}" ${ARG_SOURCES})
target_link_libraries(
"CTest_${test_name}" PRIVATE fortran-support::fortran-support
GTest::gtest_main stdc++fs)
GTest::gtest_main)
add_test(NAME "CTest_${test_name}" COMMAND "CTest_${test_name}" ${ARG_ARGS})
set_property(TEST "CTest_${test_name}" PROPERTY LABELS C)
set_target_properties("CTest_${test_name}"
......
src/mo_fortran_tools.F90
View file @ 02329904
......@@ -165,7 +165,10 @@ MODULE mo_fortran_tools
MODULE PROCEDURE copy_3d_sp
MODULE PROCEDURE copy_4d_sp
MODULE PROCEDURE copy_5d_sp
MODULE PROCEDURE copy_2d_dpsp
MODULE PROCEDURE copy_3d_dpsp
MODULE PROCEDURE copy_4d_dpsp
MODULE PROCEDURE copy_5d_dpsp
MODULE PROCEDURE copy_2d_spdp
MODULE PROCEDURE copy_3d_spdp
MODULE PROCEDURE copy_4d_spdp
......@@ -563,7 +566,7 @@ CONTAINS
m2 = SIZE(dest, 2)
!$ACC PARALLEL LOOP DEFAULT(PRESENT) ASYNC(1) COLLAPSE(2) IF(lzacc)
#ifdef __INTEL_COMPILER
#if (defined(__INTEL_COMPILER))
!$omp do private(i1,i2)
#else
!$omp do collapse(2)
......@@ -725,7 +728,7 @@ CONTAINS
m2 = SIZE(dest, 2)
!$ACC PARALLEL LOOP DEFAULT(PRESENT) ASYNC(1) COLLAPSE(2) IF(lzacc)
#ifdef __INTEL_COMPILER
#if (defined(__INTEL_COMPILER))
!$omp do private(i1,i2)
#else
!$omp do collapse(2)
......@@ -848,6 +851,36 @@ CONTAINS
CALL acc_wait_if_requested(1, opt_acc_async)
END SUBROUTINE copy_5d_sp
!> copy state, omp parallel, does not wait for other threads to complete
SUBROUTINE copy_2d_dpsp(src, dest, lacc, opt_acc_async)
REAL(dp), INTENT(IN) :: src(:, :)
REAL(sp), INTENT(OUT) :: dest(:, :)
LOGICAL, INTENT(IN) :: lacc
LOGICAL, INTENT(IN), OPTIONAL :: opt_acc_async
INTEGER :: i1, i2, m1, m2
LOGICAL :: lzacc
CALL set_acc_host_or_device(lzacc, lacc)
m1 = SIZE(dest, 1)
m2 = SIZE(dest, 2)
!$ACC PARALLEL LOOP DEFAULT(PRESENT) ASYNC(1) COLLAPSE(2) IF(lzacc)
#if (defined(__INTEL_COMPILER))
!$omp do private(i1,i2)
#else
!$omp do collapse(2)
#endif
DO i2 = 1, m2
DO i1 = 1, m1
dest(i1, i2) = REAL(src(i1, i2), KIND=sp)
END DO
END DO
!$omp end do nowait
CALL acc_wait_if_requested(1, opt_acc_async)
END SUBROUTINE copy_2d_dpsp
!> copy state, omp parallel, does not wait for other threads to complete
SUBROUTINE copy_3d_dpsp(src, dest, lacc, opt_acc_async)
REAL(dp), INTENT(IN) :: src(:, :, :)
......@@ -881,6 +914,81 @@ CONTAINS
END SUBROUTINE copy_3d_dpsp
!> copy state, omp parallel, does not wait for other threads to complete
SUBROUTINE copy_4d_dpsp(src, dest, lacc, opt_acc_async)
REAL(dp), INTENT(IN) :: src(:, :, :, :)
REAL(sp), INTENT(OUT) :: dest(:, :, :, :)
LOGICAL, INTENT(IN) :: lacc
LOGICAL, INTENT(IN), OPTIONAL :: opt_acc_async
INTEGER :: i1, i2, i3, i4, m1, m2, m3, m4
LOGICAL :: lzacc
CALL set_acc_host_or_device(lzacc, lacc)
m1 = SIZE(dest, 1)
m2 = SIZE(dest, 2)
m3 = SIZE(dest, 3)
m4 = SIZE(dest, 4)
!$ACC PARALLEL LOOP DEFAULT(PRESENT) ASYNC(1) COLLAPSE(4) IF(lzacc)
#if (defined(__INTEL_COMPILER))
!$omp do private(i1,i2,i3,i4)
#else
!$omp do collapse(4)
#endif
DO i4 = 1, m4
DO i3 = 1, m3
DO i2 = 1, m2
DO i1 = 1, m1
dest(i1, i2, i3, i4) = REAL(src(i1, i2, i3, i4), KIND=sp)
END DO
END DO
END DO
END DO
!$omp end do nowait
CALL acc_wait_if_requested(1, opt_acc_async)
END SUBROUTINE copy_4d_dpsp
!> copy state, omp parallel, does not wait for other threads to complete
SUBROUTINE copy_5d_dpsp(src, dest, lacc, opt_acc_async)
REAL(dp), INTENT(IN) :: src(:, :, :, :, :)
REAL(sp), INTENT(OUT) :: dest(:, :, :, :, :)
LOGICAL, INTENT(IN) :: lacc
LOGICAL, INTENT(IN), OPTIONAL :: opt_acc_async
INTEGER :: i1, i2, i3, i4, i5, m1, m2, m3, m4, m5
LOGICAL :: lzacc
CALL set_acc_host_or_device(lzacc, lacc)
m1 = SIZE(dest, 1)
m2 = SIZE(dest, 2)
m3 = SIZE(dest, 3)
m4 = SIZE(dest, 4)
m5 = SIZE(dest, 5)
!$ACC PARALLEL LOOP DEFAULT(PRESENT) ASYNC(1) COLLAPSE(5) IF(lzacc)
#if (defined(__INTEL_COMPILER))
!$omp do private(i1,i2,i3,i4,i5)
#else
!$omp do collapse(5)
#endif
DO i5 = 1, m5
DO i4 = 1, m4
DO i3 = 1, m3
DO i2 = 1, m2
DO i1 = 1, m1
dest(i1, i2, i3, i4, i5) = REAL(src(i1, i2, i3, i4, i5), KIND=sp)
END DO
END DO
END DO
END DO
END DO
!$omp end do nowait
CALL acc_wait_if_requested(1, opt_acc_async)
END SUBROUTINE copy_5d_dpsp
!> copy state, omp parallel, does not wait for other threads to complete
SUBROUTINE copy_2d_spdp(src, dest, lacc, opt_acc_async)
REAL(sp), INTENT(IN) :: src(:, :)
......@@ -2230,6 +2338,22 @@ CONTAINS
base_shape(2) = in_shape(2)
CALL insert_dimension_r_dp_3_2_s(ptr_out, ptr_in(1, 1), &
base_shape, new_dim_rank)
IF (in_stride(1) > 1 .OR. in_stride(2) > in_shape(1) &
.OR. base_shape(1) /= in_shape(1)) THEN
out_stride(1) = in_stride(1)
out_stride(2) = 1
out_shape(1:out_rank - 1) = in_shape
DO i = out_rank, new_dim_rank + 1, -1
out_shape(i) = out_shape(i - 1)
out_stride(i) = out_stride(i - 1)
END DO
out_stride(new_dim_rank) = 1
out_shape(new_dim_rank) = 1
out_shape = (out_shape - 1)*out_stride + 1
ptr_out => ptr_out(:out_shape(1):out_stride(1), &
& :out_shape(2):out_stride(2), &
& :out_shape(3):out_stride(3))
END IF
ELSE
out_shape(1:out_rank - 1) = SHAPE(ptr_in)
DO i = out_rank, new_dim_rank + 1, -1
......@@ -2291,6 +2415,22 @@ CONTAINS
base_shape(2) = in_shape(2)
CALL insert_dimension_r_sp_3_2_s(ptr_out, ptr_in(1, 1), &
base_shape, new_dim_rank)
IF (in_stride(1) > 1 .OR. in_stride(2) > in_shape(1) &
.OR. base_shape(1) /= in_shape(1)) THEN
out_stride(1) = in_stride(1)
out_stride(2) = 1
out_shape(1:out_rank - 1) = in_shape
DO i = out_rank, new_dim_rank + 1, -1
out_shape(i) = out_shape(i - 1)
out_stride(i) = out_stride(i - 1)
END DO
out_stride(new_dim_rank) = 1
out_shape(new_dim_rank) = 1
out_shape = (out_shape - 1)*out_stride + 1
ptr_out => ptr_out(:out_shape(1):out_stride(1), &
& :out_shape(2):out_stride(2), &
& :out_shape(3):out_stride(3))
END IF
ELSE
out_shape(1:out_rank - 1) = SHAPE(ptr_in)
DO i = out_rank, new_dim_rank + 1, -1
......@@ -2352,6 +2492,22 @@ CONTAINS
base_shape(2) = in_shape(2)
CALL insert_dimension_i4_3_2_s(ptr_out, ptr_in(1, 1), &
base_shape, new_dim_rank)
IF (in_stride(1) > 1 .OR. in_stride(2) > in_shape(1) &
.OR. base_shape(1) /= in_shape(1)) THEN
out_stride(1) = in_stride(1)
out_stride(2) = 1
out_shape(1:out_rank - 1) = in_shape
DO i = out_rank, new_dim_rank + 1, -1
out_shape(i) = out_shape(i - 1)
out_stride(i) = out_stride(i - 1)
END DO
out_stride(new_dim_rank) = 1
out_shape(new_dim_rank) = 1
out_shape = (out_shape - 1)*out_stride + 1
ptr_out => ptr_out(:out_shape(1):out_stride(1), &
& :out_shape(2):out_stride(2), &
& :out_shape(3):out_stride(3))
END IF
ELSE
out_shape(1:out_rank - 1) = SHAPE(ptr_in)
DO i = out_rank, new_dim_rank + 1, -1
......@@ -2411,6 +2567,22 @@ CONTAINS
base_shape(2) = in_shape(2)
CALL insert_dimension_l_3_2_s(ptr_out, ptr_in(1, 1), &
base_shape, new_dim_rank)
IF (in_stride(1) > 1 .OR. in_stride(2) > in_shape(1) &
.OR. base_shape(1) /= in_shape(1)) THEN
out_stride(1) = in_stride(1)
out_stride(2) = 1
out_shape(1:out_rank - 1) = in_shape
DO i = out_rank, new_dim_rank + 1, -1
out_shape(i) = out_shape(i - 1)
out_stride(i) = out_stride(i - 1)
END DO
out_stride(new_dim_rank) = 1
out_shape(new_dim_rank) = 1
out_shape = (out_shape - 1)*out_stride + 1
ptr_out => ptr_out(:out_shape(1):out_stride(1), &
& :out_shape(2):out_stride(2), &
& :out_shape(3):out_stride(3))
END IF
ELSE
out_shape(1:out_rank - 1) = SHAPE(ptr_in)
DO i = out_rank, new_dim_rank + 1, -1
......
test/c/ctest_util_stride.cpp
View file @ 02329904
......@@ -10,7 +10,7 @@
// ---------------------------------------------------------------
#include <gtest/gtest.h>
#include <experimental/random>
#include <random>
#include <util_stride.h>
......@@ -47,13 +47,17 @@ TEST_F(UtilStrideTest, CanGet1DStride) {
}
TEST_F(UtilStrideTest, CanGet1DStride2) {
std::random_device rd;
std::mt19937 gen(rd());
std::uniform_int_distribution<int> dist(0, 499);
int stride;
float f_array[1000];
double d_array[1000];
int p1 = std::experimental::randint(0, 499);
int p2 = std::experimental::randint(500, 999);
int p1 = dist(gen);
int p2 = 500 + dist(gen);
util_stride_1d(&stride, sizeof(float), &f_array[p1], &f_array[p2]);
EXPECT_EQ(stride, p2 - p1);
......@@ -78,14 +82,18 @@ TEST_F(UtilStrideTest, CanGet2DStride) {
}
TEST_F(UtilStrideTest, CanGet2DStride2) {
std::random_device rd;
std::mt19937 gen(rd());
std::uniform_int_distribution<int> dist(0, 499);
int stride[2];
float f_array[1000];
double d_array[1000];
int p1 = std::experimental::randint(0, 499);
int p2 = std::experimental::randint(500, 999);
int p3 = std::experimental::randint(500, 999);
int p1 = dist(gen);
int p2 = 500 + dist(gen);
int p3 = 500 + dist(gen);
util_stride_2d(&stride[0], sizeof(float), &f_array[p1], &f_array[p2],
&f_array[p3]);
......
test/fortran/test_fortran_tools.f90
View file @ 02329904
......@@ -414,6 +414,62 @@ CONTAINS
CALL ASSERT_EQUAL(assert_real_sp_5d_array(src, dest), .TRUE.)
END SUBROUTINE
SUBROUTINE Test_copy_2d_dpsp
REAL(dp) :: src(10, 8) = 1.0
REAL(sp) :: dest(10, 8)
CALL TAG_TEST("Test_copy_2d_dpsp_ones")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_2d_array(dest, src), .TRUE.)
CALL RANDOM_NUMBER(src)
CALL TAG_TEST("Test_copy_2d_dpsp_random")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_2d_array(dest, src), .TRUE.)
END SUBROUTINE
SUBROUTINE Test_copy_3d_dpsp
REAL(dp) :: src(10, 8, 6) = 1.0
REAL(sp) :: dest(10, 8, 6)
CALL TAG_TEST("Test_copy_3d_dpsp_ones")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_3d_array(dest, src), .TRUE.)
CALL RANDOM_NUMBER(src)
CALL TAG_TEST("Test_copy_3d_dpsp_random")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_3d_array(dest, src), .TRUE.)
END SUBROUTINE
SUBROUTINE Test_copy_4d_dpsp
REAL(dp) :: src(5, 5, 5, 5) = 1.0
REAL(sp) :: dest(5, 5, 5, 5)
CALL TAG_TEST("Test_copy_4d_dpsp_ones")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_4d_array(dest, src), .TRUE.)
CALL RANDOM_NUMBER(src)
CALL TAG_TEST("Test_copy_4d_dpsp_random")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_4d_array(dest, src), .TRUE.)
END SUBROUTINE
SUBROUTINE Test_copy_5d_dpsp
REAL(dp) :: src(5, 5, 5, 5, 5) = 1.0
REAL(sp) :: dest(5, 5, 5, 5, 5)
CALL TAG_TEST("Test_copy_5d_dpsp_ones")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_5d_array(dest, src), .TRUE.)
CALL RANDOM_NUMBER(src)
CALL TAG_TEST("Test_copy_5d_dpsp_random")
CALL copy(src, dest, .FALSE.)
CALL ASSERT_EQUAL(assert_real_spdp_5d_array(dest, src), .TRUE.)
END SUBROUTINE
SUBROUTINE Test_copy_2d_spdp
REAL(sp) :: src(10, 10) = 1.0
REAL(dp) :: dest(10, 10)
......@@ -1845,7 +1901,7 @@ CONTAINS
assert_real_spdp_2d_array = .TRUE.
DO i = 1, SIZE(array1, 1)
DO j = 1, SIZE(array1, 2)
IF (array1(i, j) /= array2(i, j)) THEN
IF (array1(i, j) /= REAL(array2(i, j), KIND=sp)) THEN
assert_real_spdp_2d_array = .FALSE.
EXIT
END IF
......@@ -1862,7 +1918,7 @@ CONTAINS
DO i = 1, SIZE(array1, 1)
DO j = 1, SIZE(array1, 2)
DO k = 1, SIZE(array1, 3)
IF (array1(i, j, k) /= array2(i, j, k)) THEN
IF (array1(i, j, k) /= REAL(array2(i, j, k), KIND=sp)) THEN
assert_real_spdp_3d_array = .FALSE.
EXIT
END IF
......@@ -1881,7 +1937,7 @@ CONTAINS
DO j = 1, SIZE(array1, 2)
DO k = 1, SIZE(array1, 3)
DO l = 1, SIZE(array1, 4)
IF (array1(i, j, k, l) /= array2(i, j, k, l)) THEN
IF (array1(i, j, k, l) /= REAL(array2(i, j, k, l), KIND=sp)) THEN
assert_real_spdp_4d_array = .FALSE.
EXIT
END IF
......@@ -1902,7 +1958,7 @@ CONTAINS
DO k = 1, SIZE(array1, 3)
DO l = 1, SIZE(array1, 4)
DO m = 1, SIZE(array1, 5)
IF (array1(i, j, k, l, m) /= array2(i, j, k, l, m)) THEN
IF (array1(i, j, k, l, m) /= REAL(array2(i, j, k, l, m), KIND=sp)) THEN
assert_real_spdp_5d_array = .FALSE.
EXIT
END IF
......

Imprint | Privacy Policy