Variant of copy for 2d dpsp (!113)

## What is the new feature
New copy variants for 2d,4d,5d fields from double-precision to single-precision.

Co-authored-by: Yen-Chen Chen <yen-chen.chen@tum.de>
Approved-by: Yen-Chen Chen <yen-chen.chen@tum.de>
Merged-by: Yen-Chen Chen <yen-chen.chen@tum.de>
Changelog: feature

src/mo_fortran_tools.F90

@@ -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(:, :)

test/fortran/test_fortran_tools.f90

@@ -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