[PATCH v2 5/5] openmp, fortran: Add support for iterators in OpenMP 'target update' constructs (Fortran)

Kwok Cheung Yeung kcyeung@baylibre.com
Tue Sep 3 17:11:53 GMT 2024


This patch adds parsing and translation of the 'to' and 'from' clauses 
for the 'target update' construct in Fortran.
-------------- next part --------------
From cfb6b76da5bba038d854d510a4fd44ddf4fa8f1f Mon Sep 17 00:00:00 2001
From: Kwok Cheung Yeung <kcyeung@baylibre.com>
Date: Mon, 2 Sep 2024 19:34:29 +0100
Subject: [PATCH 5/5] openmp, fortran: Add support for iterators in OpenMP
 'target update' constructs (Fortran)

This adds Fortran support for iterators in 'to' and 'from' clauses in the
'target update' OpenMP directive.

2024-09-02  Kwok Cheung Yeung  <kcyeung@baylibre.com>

	gcc/fortran/
	* dump-parse-tree.cc (show_omp_namelist): Add iterator support for
	OMP_LIST_TO and OMP_LIST_FROM.
	* openmp.cc (gfc_free_omp_clauses): Free namespace for OMP_LIST_TO
	and OMP_LIST_FROM.
	(gfc_match_motion_var_list): Parse 'iterator' modifier.
	(resolve_omp_clauses): Resolve iterators for OMP_LIST_TO and
	OMP_LIST_FROM.
	* trans-openmp.cc (gfc_trans_omp_clauses): Handle iterators in
	OMP_LIST_TO and OMP_LIST_FROM clauses.

	gcc/testsuite/
	* gfortran.dg/gomp/target-update-iterator-1.f90: New.
	* gfortran.dg/gomp/target-update-iterator-2.f90: New.
	* gfortran.dg/gomp/target-update-iterator-3.f90: New.

	libgomp/
	* testsuite/libgomp.fortran/target-update-iterators-1.f90: New.
	* testsuite/libgomp.fortran/target-update-iterators-2.f90: New.
	* testsuite/libgomp.fortran/target-update-iterators-3.f90: New.
---
 gcc/fortran/dump-parse-tree.cc                |  7 +-
 gcc/fortran/openmp.cc                         | 62 +++++++++++++--
 gcc/fortran/trans-openmp.cc                   | 52 +++++++++++--
 .../gomp/target-update-iterator-1.f90         | 25 ++++++
 .../gomp/target-update-iterator-2.f90         | 22 ++++++
 .../gomp/target-update-iterator-3.f90         | 23 ++++++
 .../target-update-iterators-1.f90             | 68 ++++++++++++++++
 .../target-update-iterators-2.f90             | 62 +++++++++++++++
 .../target-update-iterators-3.f90             | 77 +++++++++++++++++++
 9 files changed, 386 insertions(+), 12 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/gomp/target-update-iterator-1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/gomp/target-update-iterator-2.f90
 create mode 100644 gcc/testsuite/gfortran.dg/gomp/target-update-iterator-3.f90
 create mode 100644 libgomp/testsuite/libgomp.fortran/target-update-iterators-1.f90
 create mode 100644 libgomp/testsuite/libgomp.fortran/target-update-iterators-2.f90
 create mode 100644 libgomp/testsuite/libgomp.fortran/target-update-iterators-3.f90

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 0272a443f65..1a602fb953c 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -1350,7 +1350,8 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
     {
       gfc_current_ns = ns_curr;
       if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND
-	  || list_type == OMP_LIST_MAP)
+	  || list_type == OMP_LIST_MAP
+	  || list_type == OMP_LIST_TO || list_type == OMP_LIST_FROM)
 	{
 	  gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr;
 	  if (n->u2.ns != ns_iter)
@@ -1366,6 +1367,10 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
 		    fputs ("DEPEND (", dumpfile);
 		  else if (list_type == OMP_LIST_MAP)
 		    fputs ("MAP (", dumpfile);
+		  else if (list_type == OMP_LIST_TO)
+		    fputs ("TO (", dumpfile);
+		  else if (list_type == OMP_LIST_FROM)
+		    fputs ("FROM (", dumpfile);
 		  else
 		    gcc_unreachable ();
 		}
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 996126e6e7f..4eb4a8e53e2 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -192,7 +192,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
   for (i = 0; i < OMP_LIST_NUM; i++)
     gfc_free_omp_namelist (c->lists[i],
 			   i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND
-			   || i == OMP_LIST_MAP,
+			   || i == OMP_LIST_MAP
+			   || i == OMP_LIST_TO || i == OMP_LIST_FROM,
 			   i == OMP_LIST_ALLOCATE,
 			   i == OMP_LIST_USES_ALLOCATORS);
   gfc_free_expr_list (c->wait_list);
@@ -1362,17 +1363,65 @@ gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
   if (m != MATCH_YES)
     return m;
 
-  match m_present = gfc_match (" present : ");
+  gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
+  int present_modifier = 0, iterator_modifier = 0;
+  locus present_locus = gfc_current_locus, iterator_locus = gfc_current_locus;
 
-  m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
+  for (;;)
+    {
+      locus current_locus = gfc_current_locus;
+      if (gfc_match ("present ") == MATCH_YES)
+	{
+	  if (present_modifier++ == 1)
+	    present_locus = current_locus;
+	}
+      else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
+	{
+	  if (iterator_modifier++ == 1)
+	    iterator_locus = current_locus;
+	}
+      else
+	break;
+      gfc_match (", ");
+    }
+
+  if (present_modifier > 1)
+    {
+      gfc_error ("too many %<present%> modifiers at %L",
+		 &present_locus);
+      return MATCH_ERROR;
+    }
+  if (iterator_modifier > 1)
+    {
+      gfc_error ("too many %<iterator%> modifiers at %L",
+		 &iterator_locus);
+      return MATCH_ERROR;
+    }
+
+  if (ns_iter)
+    gfc_current_ns = ns_iter;
+
+  const char *exp = (present_modifier || iterator_modifier) ? " :" : "";
+  m = gfc_match_omp_variable_list (exp, list, false, NULL, headp, true, true);
+  gfc_current_ns = ns_curr;
   if (m != MATCH_YES)
     return m;
-  if (m_present == MATCH_YES)
+
+  if (present_modifier || iterator_modifier)
     {
       gfc_omp_namelist *n;
       for (n = **headp; n; n = n->next)
-	n->u.present_modifier = true;
+	{
+	  if (present_modifier)
+	    n->u.present_modifier = true;
+	  if (iterator_modifier)
+	    {
+	      n->u2.ns = ns_iter;
+	      ns_iter->refs++;
+	    }
+	}
     }
+
   return MATCH_YES;
 }
 
@@ -8436,7 +8485,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 	    for (; n != NULL; n = n->next)
 	      {
 		if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY
-		     || list == OMP_LIST_MAP)
+		     || list == OMP_LIST_MAP
+		     || list == OMP_LIST_TO || list == OMP_LIST_FROM)
 		    && n->u2.ns && !n->u2.ns->resolved)
 		  {
 		    n->u2.ns->resolved = 1;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index a9929430e53..1be8f2ad806 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -4052,11 +4052,40 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 	case OMP_LIST_TO:
 	case OMP_LIST_FROM:
 	case OMP_LIST_CACHE:
+	  iterator = NULL_TREE;
+	  prev = NULL;
+	  prev_clauses = omp_clauses;
 	  for (; n != NULL; n = n->next)
 	    {
 	      if (!n->sym->attr.referenced)
 		continue;
 
+	      if (iterator && prev->u2.ns != n->u2.ns)
+		{
+		  /* Finish previous iterator group.  */
+		  BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
+		  TREE_VEC_ELT (iterator, 5) = tree_block;
+		  for (tree c = omp_clauses; c != prev_clauses;
+		       c = OMP_CLAUSE_CHAIN (c))
+		    OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
+							   OMP_CLAUSE_DECL (c));
+		  prev_clauses = omp_clauses;
+		  iterator = NULL_TREE;
+		}
+	      if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
+		{
+		  /* Start a new iterator group.  */
+		  gfc_init_block (&iter_block);
+		  tree_block = make_node (BLOCK);
+		  TREE_USED (tree_block) = 1;
+		  BLOCK_VARS (tree_block) = NULL_TREE;
+		  prev_clauses = omp_clauses;
+		  iterator = handle_iterator (n->u2.ns, block, tree_block);
+		}
+	      if (!iterator)
+		gfc_init_block (&iter_block);
+	      prev = n;
+
 	      switch (list)
 		{
 		case OMP_LIST_TO:
@@ -4094,7 +4123,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		      ptr = build_fold_indirect_ref (ptr);
 		      OMP_CLAUSE_DECL (node) = ptr;
 		      OMP_CLAUSE_SIZE (node)
-			= gfc_full_array_size (block, decl,
+			= gfc_full_array_size (&iter_block, decl,
 					       GFC_TYPE_ARRAY_RANK (type));
 		      tree elemsz
 			= TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -4119,7 +4148,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		    {
 		      gfc_conv_expr_reference (&se, n->expr);
 		      ptr = se.expr;
-		      gfc_add_block_to_block (block, &se.pre);
+		      gfc_add_block_to_block (&iter_block, &se.pre);
 		      OMP_CLAUSE_SIZE (node)
 			= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
 		    }
@@ -4128,9 +4157,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		      gfc_conv_expr_descriptor (&se, n->expr);
 		      ptr = gfc_conv_array_data (se.expr);
 		      tree type = TREE_TYPE (se.expr);
-		      gfc_add_block_to_block (block, &se.pre);
+		      gfc_add_block_to_block (&iter_block, &se.pre);
 		      OMP_CLAUSE_SIZE (node)
-			= gfc_full_array_size (block, se.expr,
+			= gfc_full_array_size (&iter_block, se.expr,
 					       GFC_TYPE_ARRAY_RANK (type));
 		      tree elemsz
 			= TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -4139,7 +4168,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 			= fold_build2 (MULT_EXPR, gfc_array_index_type,
 				       OMP_CLAUSE_SIZE (node), elemsz);
 		    }
-		  gfc_add_block_to_block (block, &se.post);
+		  gfc_add_block_to_block (&iter_block, &se.post);
 		  gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
 		  OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
 		}
@@ -4147,8 +4176,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		OMP_CLAUSE_MOTION_PRESENT (node) = 1;
 	      if (list == OMP_LIST_CACHE && n->u.map.readonly)
 		OMP_CLAUSE__CACHE__READONLY (node) = 1;
+
+	      if (!iterator)
+		gfc_add_block_to_block (block, &iter_block);
 	      omp_clauses = gfc_trans_add_clause (node, omp_clauses);
 	    }
+	  if (iterator)
+	    {
+	      /* Finish last iterator group.  */
+	      BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
+	      TREE_VEC_ELT (iterator, 5) = tree_block;
+	      for (tree c = omp_clauses; c != prev_clauses;
+		c = OMP_CLAUSE_CHAIN (c))
+	      OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
+						     OMP_CLAUSE_DECL (c));
+	    }
 	  break;
 	case OMP_LIST_USES_ALLOCATORS:
 	  /* Ignore pre-defined allocators as no special treatment is needed. */
diff --git a/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-1.f90 b/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-1.f90
new file mode 100644
index 00000000000..08dc3d79911
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-1.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+
+program test
+  implicit none
+
+  integer, parameter :: DIM1 = 17
+  integer, parameter :: DIM2 = 39
+
+  type :: array_ptr
+    integer, pointer :: ptr(:)
+  end type
+
+  type (array_ptr) :: x(DIM1), y(DIM1)
+
+  !$omp target update to (iterator(i=1:DIM1): x(i)%ptr(:))
+
+  !$omp target update to (iterator(i=1:DIM1): x(i)%ptr(:DIM2), y(i)%ptr(:))
+
+  !$omp target update to (iterator(i=1:DIM1), present: x(i)%ptr(:))
+
+  !$omp target update to (iterator(i=1:DIM1), iterator(j=i:DIM2): x(i)%ptr(j)) ! { dg-error "too many 'iterator' modifiers at .1." }
+
+  !$omp target update to (iterator(i=1:DIM1), something: x(i, j)) ! { dg-error "Failed to match clause at .1." }
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-2.f90 b/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-2.f90
new file mode 100644
index 00000000000..89f645bda23
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-2.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+
+program test
+  implicit none
+
+  integer, parameter :: DIM1 = 17
+  integer, parameter :: DIM2 = 39
+
+  type :: array_ptr
+    integer, pointer :: ptr(:)
+  end type
+
+  type (array_ptr) :: x(DIM1), y(DIM1), z(DIM1)
+
+  !$omp target update to(iterator(i=1:10): x) ! { dg-error "iterator variable .i. not used in clause expression" }
+  !$omp target update from(iterator(i=1:10, j=1:20): x(i)) ! { dg-error "iterator variable .j. not used in clause expression" }
+  !$omp target update to(iterator(i=1:10, j=1:20, k=1:30): x(i), y(j), z(k))
+  ! { dg-error "iterator variable .i. not used in clause expression" "" { target *-*-* } .-1 }
+  ! { dg-error "iterator variable .j. not used in clause expression" "" { target *-*-* } .-2 }
+  ! { dg-error "iterator variable .k. not used in clause expression" "" { target *-*-* } .-3 }
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-3.f90 b/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-3.f90
new file mode 100644
index 00000000000..a8b8ce8f171
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/target-update-iterator-3.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-gimple" }
+
+program test
+  implicit none
+
+  integer, parameter :: DIM1 = 17
+  integer, parameter :: DIM2 = 39
+
+  type :: array_ptr
+    integer, pointer :: ptr(:)
+  end type
+
+  type (array_ptr) :: x(DIM1, DIM2), y(DIM1, DIM2), z(DIM1)
+
+  !$omp target update to (iterator(i=1:DIM1, j=1:DIM2): x(i, j)%ptr(:), y(i, j)%ptr(:))
+  !$omp target update from (iterator(i=1:DIM1): z(i)%ptr(:))
+end program
+
+! { dg-final { scan-tree-dump-times "if \\(i <= 17\\) goto <D\.\[0-9\]+>; else goto <D\.\[0-9\]+>;" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "if \\(j <= 39\\) goto <D\.\[0-9\]+>; else goto <D\.\[0-9\]+>;" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "to\\(iterator\\(integer\\(kind=4\\) j=1:39:1, integer\\(kind=4\\) i=1:17:1\\):iterator_array=D\.\[0-9\]+" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "from\\(iterator\\(integer\\(kind=4\\) i=1:17:1\\):iterator_array=D\.\[0-9\]+" 1 "gimple" } }
diff --git a/libgomp/testsuite/libgomp.fortran/target-update-iterators-1.f90 b/libgomp/testsuite/libgomp.fortran/target-update-iterators-1.f90
new file mode 100644
index 00000000000..e9a13a3c737
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-update-iterators-1.f90
@@ -0,0 +1,68 @@
+! { dg-do run }
+
+! Test target enter data and target update to the target using map
+! iterators.
+
+program test
+  integer, parameter :: DIM1 = 8
+  integer, parameter :: DIM2 = 15
+
+  type :: array_ptr
+    integer, pointer :: arr(:)
+  end type
+
+  type (array_ptr) :: x(DIM1)
+  integer :: expected, sum, i, j
+
+  expected = mkarray (x)
+
+  !$omp target enter data map(to: x)
+  !$omp target enter data map(iterator(i=1:DIM1), to: x(i)%arr(:))
+  !$omp target map(from: sum)
+    sum = 0
+    do i = 1, DIM1
+      do j = 1, DIM2
+	sum = sum + x(i)%arr(j)
+      end do
+    end do
+  !$omp end target
+
+  print *, sum, expected
+  if (sum .ne. expected) stop 1
+
+  expected = 0
+  do i = 1, DIM1
+    do j = 1, DIM2
+      x(i)%arr(j) = x(i)%arr(j) * i * j
+      expected = expected + x(i)%arr(j)
+    end do
+  end do
+
+  !$omp target update to(iterator(i=1:DIM1): x(i)%arr(:))
+
+  !$omp target map(from: sum)
+    sum = 0
+    do i = 1, DIM1
+      do j = 1, DIM2
+	sum = sum + x(i)%arr(j)
+      end do
+    end do
+  !$omp end target
+
+  if (sum .ne. expected) stop 2
+contains
+  integer function mkarray (x)
+    type (array_ptr), intent(inout) :: x(DIM1)
+    integer :: exp = 0
+
+    do i = 1, DIM1
+      allocate (x(i)%arr(DIM2))
+      do j = 1, DIM2
+	x(i)%arr(j) = i * j
+	exp = exp + x(i)%arr(j)
+      end do
+    end do
+
+    mkarray = exp
+  end function
+end program
diff --git a/libgomp/testsuite/libgomp.fortran/target-update-iterators-2.f90 b/libgomp/testsuite/libgomp.fortran/target-update-iterators-2.f90
new file mode 100644
index 00000000000..6c1a8a7b5dd
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-update-iterators-2.f90
@@ -0,0 +1,62 @@
+! { dg-do run }
+
+! Test target enter data and target update from the target using map
+! iterators.
+
+program test
+  integer, parameter :: DIM1 = 8
+  integer, parameter :: DIM2 = 15
+
+  type :: array_ptr
+    integer, pointer :: arr(:)
+  end type
+
+  type (array_ptr) :: x(DIM1)
+  integer :: sum, expected
+
+  call mkarray (x)
+
+  !$omp target enter data map(to: x(:DIM1))
+  !$omp target enter data map(iterator(i=1:DIM1), to: x(i)%arr(:))
+  !$omp target map(from: expected)
+    expected = 0
+    do i = 1, DIM1
+      do j = 1, DIM2
+	x(i)%arr(j) = (i + 1) * (j + 2)
+	expected = expected + x(i)%arr(j)
+      end do
+    end do
+  !$omp end target
+
+  ! Host copy of x should remain unchanged.
+  sum = 0
+  do i = 1, DIM1
+    do j = 1, DIM2
+      sum = sum + x(i)%arr(j)
+    end do
+  end do
+  if (sum .ne. 0) stop 1
+
+  !$omp target update from(iterator(i=1:DIM1): x(i)%arr(:))
+
+  ! Host copy should now be updated.
+  sum = 0
+  do i = 1, DIM1
+    do j = 1, DIM2
+      sum = sum + x(i)%arr(j)
+    end do
+  end do
+
+  if (sum .ne. expected) stop 2
+contains
+  subroutine mkarray (x)
+    type (array_ptr), intent(inout) :: x(DIM1)
+
+    do i = 1, DIM1
+      allocate (x(i)%arr(DIM2))
+      do j = 1, DIM2
+	x(i)%arr(j) = 0
+      end do
+    end do
+  end subroutine
+end program
diff --git a/libgomp/testsuite/libgomp.fortran/target-update-iterators-3.f90 b/libgomp/testsuite/libgomp.fortran/target-update-iterators-3.f90
new file mode 100644
index 00000000000..8dbfb45fe8d
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-update-iterators-3.f90
@@ -0,0 +1,77 @@
+! { dg-do run }
+
+! Test target enter data and target update to the target using map
+! iterators with a function.
+
+program test
+  implicit none
+
+  integer, parameter :: DIM1 = 8
+  integer, parameter :: DIM2 = 15
+
+  type :: array_ptr
+    integer, pointer :: arr(:)
+  end type
+
+  type (array_ptr) :: x(DIM1)
+  integer :: x_new(DIM1, DIM2)
+  integer :: expected, sum, i, j
+
+  call mkarray (x)
+
+  !$omp target enter data map(to: x(:DIM1))
+  !$omp target enter data map(iterator(i=1:DIM1), to: x(i)%arr(:))
+
+  ! Update x on host.
+  do i = 1, DIM1
+    do j = 1, DIM2
+      x_new(i, j) = x(i)%arr(j)
+      x(i)%arr(j) = (i + 1) * (j + 2);
+    end do
+  end do
+
+  ! Update a subset of x on target.
+  !$omp target update to(iterator(i=1:DIM1/2): x(f (i))%arr(:))
+
+  !$omp target map(from: sum)
+    sum = 0
+    do i = 1, DIM1
+      do j = 1, DIM2
+	sum = sum + x(i)%arr(j)
+      end do
+    end do
+  !$omp end target
+
+  ! Calculate expected value on host.
+  do i = 1, DIM1/2
+    do j = 1, DIM2
+      x_new(f (i), j) = x(f (i))%arr(j)
+    end do
+  end do
+
+  expected = 0
+  do i = 1, DIM1
+    do j = 1, DIM2
+      expected = expected + x_new(i, j)
+    end do
+  end do
+
+  if (sum .ne. expected) stop 1
+contains
+  subroutine mkarray (x)
+    type (array_ptr), intent(inout) :: x(DIM1)
+
+    do i = 1, DIM1
+      allocate (x(i)%arr(DIM2))
+      do j = 1, DIM2
+	x(i)%arr(j) = i * j
+      end do
+    end do
+  end subroutine
+
+  integer function f (i)
+    integer, intent(in) :: i
+
+    f = i * 2
+  end function
+end program
-- 
2.34.1



More information about the Fortran mailing list