resolve.c (resolve_ordinary_assign): Don't invoke caf_send when assigning a coindexed...

2014-06-25  Tobias Burnus  <burnus@net-b.de>

fortran/
        * resolve.c (resolve_ordinary_assign): Don't invoke caf_send
        when assigning a coindexed RHS scalar to a noncoindexed LHS
        array.
        * trans-intrinsic.c (conv_caf_send): Do numeric type conversion
        for a noncoindexed scalar RHS.

gcc/testsuite/
        * gfortran.dg/coarray/coindexed_1.f90: New.

libgfortran/
        * caf/single.c (assign_char4_from_char1,
        * assign_char1_from_char4,
        convert_type): New static functions.
        (_gfortran_caf_get, _gfortran_caf_send): Use them.

From-SVN: r211993

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 12606ffeaa89a4a0e391941114e56be5506696c0..d92a88f31a074de6a7d4c6f301651e379582115f 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,10 +1,19 @@
+2014-06-25  Tobias Burnus  <burnus@net-b.de>
+
+       * resolve.c (resolve_ordinary_assign): Don't invoke caf_send
+       when assigning a coindexed RHS scalar to a noncoindexed LHS
+       array.
+       * trans-intrinsic.c (conv_caf_send): Do numeric type conversion
+       for a noncoindexed scalar RHS.
+
 2014-06-25  Tobias Burnus  <burnus@net-b.de>
 
        * check.c (check_co_minmaxsum): Add definable check.
        * expr.c (gfc_check_vardef_context): Fix context == NULL case.
-       * trans-expr.c (get_scalar_to_descriptor_type): Handle pointer arguments.
-       * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Fix generation of temporary
-       strings.
+       * trans-expr.c (get_scalar_to_descriptor_type): Handle pointer
+       arguments.
+       * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Fix generation of
+       temporary strings.
 
 2014-06-25  Jakub Jelinek  <jakub@redhat.com>
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 48b3a40f769d75a3b03cc68653622c6a372cd083..ca20c294243f10e9e79a806a4a8ecc26772f2b47 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9300,12 +9300,15 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
   /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
      Additionally, insert this code when the RHS is a CAF as we then use the
      GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
-     the LHS is (re)allocatable or has a vector subscript.  */
+     the LHS is (re)allocatable or has a vector subscript.  If the LHS is a
+     noncoindexed array and the RHS is a coindexed scalar, use the normal code
+     path.  */
   if (gfc_option.coarray == GFC_FCOARRAY_LIB
       && (lhs_coindexed
          || (code->expr2->expr_type == EXPR_FUNCTION
              && code->expr2->value.function.isym
              && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
+             && (code->expr1->rank == 0 || code->expr2->rank != 0)
              && !gfc_expr_attr (rhs).allocatable
               && !gfc_has_vector_subscript (rhs))))
     {

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a0c74218e63170a29bbbec002dc8359cae00adbf..a1dfdfb2f83694130edc65c33e934cc98f71823c 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1349,6 +1349,7 @@ conv_caf_send (gfc_code *code) {
   gfc_se lhs_se, rhs_se;
   stmtblock_t block;
   tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
+  tree lhs_type = NULL_TREE;
   tree vec = null_pointer_node, rhs_vec = null_pointer_node;
 
   gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
@@ -1364,6 +1365,7 @@ conv_caf_send (gfc_code *code) {
       symbol_attribute attr;
       gfc_clear_attr (&attr);
       gfc_conv_expr (&lhs_se, lhs_expr);
+      lhs_type = TREE_TYPE (lhs_se.expr);
       lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
       lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
     }
@@ -1385,6 +1387,7 @@ conv_caf_send (gfc_code *code) {
        }
       lhs_se.want_pointer = 1;
       gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
+      lhs_type = gfc_get_element_type (TREE_TYPE (TREE_TYPE (lhs_se.expr)));
       if (has_vector)
        {
          vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar);
@@ -1418,11 +1421,16 @@ conv_caf_send (gfc_code *code) {
 
   /* RHS.  */
   gfc_init_se (&rhs_se, NULL);
+  if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
+      && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
+    rhs_expr = rhs_expr->value.function.actual->expr;
   if (rhs_expr->rank == 0)
     {
       symbol_attribute attr;
       gfc_clear_attr (&attr);
       gfc_conv_expr (&rhs_se, rhs_expr);
+      if (!gfc_is_coindexed (rhs_expr) && rhs_expr->ts.type != BT_CHARACTER)
+        rhs_se.expr = fold_convert (lhs_type , rhs_se.expr);
       rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
       rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
     }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7046ff741056a5acae7685d4a18c4679da64267a..0735c448cc1948e8430cdbd4012b5ba0d62bb856 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2014-06-25  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/coarray/coindexed_1.f90: New.
+
 2014-06-25  Tobias Burnus  <burnus@net-b.de>
 
        * gfortran.dg/coarray_collectives_7.f90: New.

diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90
new file mode 100644 (file)
index 0000000..86f86d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90
@@ -0,0 +1,1459 @@
+! { dg-do run }
+!
+!
+program test
+  implicit none
+  call char_test()
+contains
+subroutine char_test()
+  character(len=3, kind=1), save :: str1a[*], str1b(5)[*]
+  character(len=7, kind=1), save :: str2a[*], str2b(5)[*]
+  character(len=3, kind=4), save :: ustr1a[*], ustr1b(5)[*]
+  character(len=7, kind=4), save :: ustr2a[*], ustr2b(5)[*]
+
+  ! ---------- Assign to coindexed variable -------------
+
+  ! - - - - - scalar = scalar
+
+  ! SCALAR - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  str2a = 1_"XXXXXXX"
+  if (this_image() == num_images()) then
+    str2a[1] = str1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2a /= 1_"abc    ") call abort()
+  else
+    if (str2a /= 1_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  ustr2a = 4_"XXXXXXX"
+  if (this_image() == num_images()) then
+    ustr2a[1] = ustr1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2a /= 4_"abc    ") call abort()
+  else
+    if (ustr2a /= 4_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcde"
+  str1a = 1_"XXX"
+  if (this_image() == num_images()) then
+    str1a[1] = str2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1a /= 1_"abc") call abort()
+  else
+    if (str1a /= 1_"XXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcde"
+  ustr1a = 4_"XXX"
+  if (this_image() == num_images()) then
+    ustr1a[1] = ustr2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1a /= 4_"abc") call abort()
+  else
+    if (ustr1a /= 4_"XXX") call abort()
+  end if
+
+  ! - - - - - array = array
+
+  ! contiguous ARRAY - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1b(1) = 1_"abc"
+  str1b(2) = 1_"def"
+  str1b(3) = 1_"gjh"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = str1b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"def    " &
+        .or. str2b(3) /= 1_"gjh    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1b(1) = 4_"abc"
+  ustr1b(2) = 4_"def"
+  ustr1b(3) = 4_"gjh"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = ustr1b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"def    " &
+        .or. ustr2b(3) /= 4_"gjh    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2b(1) = 1_"abcdefg"
+  str2b(2) = 1_"hijklmn"
+  str2b(3) = 1_"opqrstu"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = str2b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" &
+        .or. str1b(3) /= 1_"opq") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2b(1) = 4_"abcdefg"
+  ustr2b(2) = 4_"hijklmn"
+  ustr2b(3) = 4_"opqrstu"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = ustr2b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" &
+        .or. ustr1b(3) /= 4_"opq") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! - - - - - array = scalar
+
+  ! contiguous ARRAY - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = str1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"abc    " &
+        .or. str2b(3) /= 1_"abc    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = ustr1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"abc    " &
+        .or. ustr2b(3) /= 4_"abc    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcdefg"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = str2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" &
+        .or. str1b(3) /= 1_"abc") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcdefg"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = ustr2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" &
+        .or. ustr1b(3) /= 4_"abc") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! ---------- Take from a coindexed variable -------------
+
+  ! - - - - - scalar = scalar
+
+  ! SCALAR - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  str2a = 1_"XXXXXXX"
+  if (this_image() == num_images()) then
+    str2a = str1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str2a /= 1_"abc    ") call abort()
+  else
+    if (str2a /= 1_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  ustr2a = 4_"XXXXXXX"
+  if (this_image() == num_images()) then
+    ustr2a = ustr1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr2a /= 4_"abc    ") call abort()
+  else
+    if (ustr2a /= 4_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcde"
+  str1a = 1_"XXX"
+  if (this_image() == num_images()) then
+    str1a = str2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str1a /= 1_"abc") call abort()
+  else
+    if (str1a /= 1_"XXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcde"
+  ustr1a = 4_"XXX"
+  if (this_image() == num_images()) then
+    ustr1a = ustr2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr1a /= 4_"abc") call abort()
+  else
+    if (ustr1a /= 4_"XXX") call abort()
+  end if
+
+  ! - - - - - array = array
+
+  ! contiguous ARRAY - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1b(1) = 1_"abc"
+  str1b(2) = 1_"def"
+  str1b(3) = 1_"gjh"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b = str1b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"def    " &
+        .or. str2b(3) /= 1_"gjh    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1b(1) = 4_"abc"
+  ustr1b(2) = 4_"def"
+  ustr1b(3) = 4_"gjh"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b = ustr1b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"def    " &
+        .or. ustr2b(3) /= 4_"gjh    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2b(1) = 1_"abcdefg"
+  str2b(2) = 1_"hijklmn"
+  str2b(3) = 1_"opqrstu"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b = str2b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" &
+        .or. str1b(3) /= 1_"opq") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2b(1) = 4_"abcdefg"
+  ustr2b(2) = 4_"hijklmn"
+  ustr2b(3) = 4_"opqrstu"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b = ustr2b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" &
+        .or. ustr1b(3) /= 4_"opq") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! - - - - - array = scalar
+
+  ! contiguous ARRAY - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b = str1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"abc    " &
+        .or. str2b(3) /= 1_"abc    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b = ustr1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"abc    " &
+        .or. ustr2b(3) /= 4_"abc    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcdefg"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b = str2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" &
+        .or. str1b(3) /= 1_"abc") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcdefg"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b = ustr2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" &
+        .or. ustr1b(3) /= 4_"abc") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+
+  ! ---------- coindexed to coindexed variable -------------
+
+  ! - - - - - scalar = scalar
+
+  ! SCALAR - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  str2a = 1_"XXXXXXX"
+  if (this_image() == num_images()) then
+    str2a[1] = str1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2a /= 1_"abc    ") call abort()
+  else
+    if (str2a /= 1_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  ustr2a = 4_"XXXXXXX"
+  if (this_image() == num_images()) then
+    ustr2a[1] = ustr1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2a /= 4_"abc    ") call abort()
+  else
+    if (ustr2a /= 4_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcde"
+  str1a = 1_"XXX"
+  if (this_image() == num_images()) then
+    str1a[1] = str2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1a /= 1_"abc") call abort()
+  else
+    if (str1a /= 1_"XXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcde"
+  ustr1a = 4_"XXX"
+  if (this_image() == num_images()) then
+    ustr1a[1] = ustr2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1a /= 4_"abc") call abort()
+  else
+    if (ustr1a /= 4_"XXX") call abort()
+  end if
+
+  ! - - - - - array = array
+
+  ! contiguous ARRAY - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1b(1) = 1_"abc"
+  str1b(2) = 1_"def"
+  str1b(3) = 1_"gjh"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = str1b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"def    " &
+        .or. str2b(3) /= 1_"gjh    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1b(1) = 4_"abc"
+  ustr1b(2) = 4_"def"
+  ustr1b(3) = 4_"gjh"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"def    " &
+        .or. ustr2b(3) /= 4_"gjh    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2b(1) = 1_"abcdefg"
+  str2b(2) = 1_"hijklmn"
+  str2b(3) = 1_"opqrstu"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = str2b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" &
+        .or. str1b(3) /= 1_"opq") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2b(1) = 4_"abcdefg"
+  ustr2b(2) = 4_"hijklmn"
+  ustr2b(3) = 4_"opqrstu"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" &
+        .or. ustr1b(3) /= 4_"opq") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! - - - - - array = scalar
+
+  ! contiguous ARRAY - kind 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = str1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"abc    " &
+        .or. str2b(3) /= 1_"abc    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = ustr1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"abc    " &
+        .or. ustr2b(3) /= 4_"abc    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcdefg"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = str2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" &
+        .or. str1b(3) /= 1_"abc") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcdefg"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = ustr2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" &
+        .or. ustr1b(3) /= 4_"abc") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! ============== char1 <-> char4 =====================
+
+  ! ---------- Assign to coindexed variable -------------
+
+  ! - - - - - scalar = scalar
+
+  ! SCALAR - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  str1a = 1_"XXXXXXX"
+  if (this_image() == num_images()) then
+    str2a[1] = ustr1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2a /= 1_"abc    ") call abort()
+  else
+    if (str2a /= 1_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 4_"abc"
+  ustr2a = 1_"XXXXXXX"
+  if (this_image() == num_images()) then
+    ustr2a[1] = str1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2a /= 4_"abc    ") call abort()
+  else
+    if (ustr2a /= 4_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcde"
+  str1a = 1_"XXX"
+  if (this_image() == num_images()) then
+    str1a[1] = ustr2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1a /= 1_"abc") call abort()
+  else
+    if (str1a /= 1_"XXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 4_"abcde"
+  ustr1a = 1_"XXX"
+  if (this_image() == num_images()) then
+    ustr1a[1] = str2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1a /= 4_"abc") call abort()
+  else
+    if (ustr1a /= 4_"XXX") call abort()
+  end if
+
+  ! - - - - - array = array
+
+  ! contiguous ARRAY - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1b(1) = 4_"abc"
+  ustr1b(2) = 4_"def"
+  ustr1b(3) = 4_"gjh"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = ustr1b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"def    " &
+        .or. str2b(3) /= 1_"gjh    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1b(1) = 1_"abc"
+  str1b(2) = 1_"def"
+  str1b(3) = 1_"gjh"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = str1b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"def    " &
+        .or. ustr2b(3) /= 4_"gjh    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2b(1) = 4_"abcdefg"
+  ustr2b(2) = 4_"hijklmn"
+  ustr2b(3) = 4_"opqrstu"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = ustr2b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" &
+        .or. str1b(3) /= 1_"opq") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2b(1) = 1_"abcdefg"
+  str2b(2) = 1_"hijklmn"
+  str2b(3) = 1_"opqrstu"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = str2b
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" &
+        .or. ustr1b(3) /= 4_"opq") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! - - - - - array = scalar
+
+  ! contiguous ARRAY - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = ustr1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"abc    " &
+        .or. str2b(3) /= 1_"abc    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = str1a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"abc    " &
+        .or. ustr2b(3) /= 4_"abc    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcdefg"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = ustr2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" &
+        .or. str1b(3) /= 1_"abc") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcdefg"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = str2a
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" &
+        .or. ustr1b(3) /= 4_"abc") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! ---------- Take from a coindexed variable -------------
+
+  ! - - - - - scalar = scalar
+
+  ! SCALAR - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  str2a = 1_"XXXXXXX"
+  if (this_image() == num_images()) then
+    str2a = ustr1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str2a /= 1_"abc    ") call abort()
+  else
+    if (str2a /= 1_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  ustr2a = 4_"XXXXXXX"
+  if (this_image() == num_images()) then
+    ustr2a = str1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr2a /= 4_"abc    ") call abort()
+  else
+    if (ustr2a /= 4_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcde"
+  str1a = 1_"XXX"
+  if (this_image() == num_images()) then
+    str1a = ustr2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str1a /= 1_"abc") call abort()
+  else
+    if (str1a /= 1_"XXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcde"
+  ustr1a = 4_"XXX"
+  if (this_image() == num_images()) then
+    ustr1a = str2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr1a /= 4_"abc") call abort()
+  else
+    if (ustr1a /= 4_"XXX") call abort()
+  end if
+
+  ! - - - - - array = array
+
+  ! contiguous ARRAY - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1b(1) = 4_"abc"
+  ustr1b(2) = 4_"def"
+  ustr1b(3) = 4_"gjh"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b = ustr1b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"def    " &
+        .or. str2b(3) /= 1_"gjh    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1b(1) = 1_"abc"
+  str1b(2) = 1_"def"
+  str1b(3) = 1_"gjh"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b = str1b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"def    " &
+        .or. ustr2b(3) /= 4_"gjh    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2b(1) = 4_"abcdefg"
+  ustr2b(2) = 4_"hijklmn"
+  ustr2b(3) = 4_"opqrstu"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b = ustr2b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" &
+        .or. str1b(3) /= 1_"opq") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2b(1) = 1_"abcdefg"
+  str2b(2) = 1_"hijklmn"
+  str2b(3) = 1_"opqrstu"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b = str2b(:)[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" &
+        .or. ustr1b(3) /= 4_"opq") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! - - - - - array = scalar
+
+  ! contiguous ARRAY - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b = ustr1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"abc    " &
+        .or. str2b(3) /= 1_"abc    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b = str1a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"abc    " &
+        .or. ustr2b(3) /= 4_"abc    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcdefg"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b = ustr2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" &
+        .or. str1b(3) /= 1_"abc") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcdefg"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b = str2a[1]
+  end if
+  sync all
+  if (this_image() == num_images()) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" &
+        .or. ustr1b(3) /= 4_"abc") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+
+  ! ---------- coindexed to coindexed variable -------------
+
+  ! - - - - - scalar = scalar
+
+  ! SCALAR - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  str2a = 1_"XXXXXXX"
+  if (this_image() == num_images()) then
+    str2a[1] = ustr1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2a /= 1_"abc    ") call abort()
+  else
+    if (str2a /= 1_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  ustr2a = 4_"XXXXXXX"
+  if (this_image() == num_images()) then
+    ustr2a[1] = str1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2a /= 4_"abc    ") call abort()
+  else
+    if (ustr2a /= 4_"XXXXXXX") call abort()
+  end if
+
+  ! SCALAR - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcde"
+  str1a = 1_"XXX"
+  if (this_image() == num_images()) then
+    str1a[1] = ustr2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1a /= 1_"abc") call abort()
+  else
+    if (str1a /= 1_"XXX") call abort()
+  end if
+
+  ! SCALAR - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcde"
+  ustr1a = 4_"XXX"
+  if (this_image() == num_images()) then
+    ustr1a[1] = str2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1a /= 4_"abc") call abort()
+  else
+    if (ustr1a /= 4_"XXX") call abort()
+  end if
+
+  ! - - - - - array = array
+
+  ! contiguous ARRAY - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1b(1) = 4_"abc"
+  ustr1b(2) = 4_"def"
+  ustr1b(3) = 4_"gjh"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"def    " &
+        .or. str2b(3) /= 1_"gjh    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1b(1) = 1_"abc"
+  str1b(2) = 1_"def"
+  str1b(3) = 1_"gjh"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = str1b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"def    " &
+        .or. ustr2b(3) /= 4_"gjh    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2b(1) = 4_"abcdefg"
+  ustr2b(2) = 4_"hijklmn"
+  ustr2b(3) = 4_"opqrstu"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" &
+        .or. str1b(3) /= 1_"opq") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2b(1) = 1_"abcdefg"
+  str2b(2) = 1_"hijklmn"
+  str2b(3) = 1_"opqrstu"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = str2b(:)[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" &
+        .or. ustr1b(3) /= 4_"opq") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+  ! - - - - - array = scalar
+
+  ! contiguous ARRAY - kind 1 <- 4 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr1a = 4_"abc"
+  str2b(1) = 1_"XXXXXXX"
+  str2b(2) = 1_"YYYYYYY"
+  str2b(3) = 1_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    str2b(:)[1] = ustr1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str2b(1) /= 1_"abc    " .or. str2b(2) /= 1_"abc    " &
+        .or. str2b(3) /= 1_"abc    ") call abort()
+  else
+    if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" &
+        .or. str2b(3) /= 1_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with padding
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str1a = 1_"abc"
+  ustr2b(1) = 4_"XXXXXXX"
+  ustr2b(2) = 4_"YYYYYYY"
+  ustr2b(3) = 4_"ZZZZZZZ"
+  if (this_image() == num_images()) then
+    ustr2b(:)[1] = str1a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr2b(1) /= 4_"abc    " .or. ustr2b(2) /= 4_"abc    " &
+        .or. ustr2b(3) /= 4_"abc    ") call abort()
+  else
+    if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" &
+        .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 1 <- 4 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  ustr2a = 4_"abcdefg"
+  str1b(1) = 1_"XXX"
+  str1b(2) = 1_"YYY"
+  str1b(3) = 1_"ZZZ"
+  if (this_image() == num_images()) then
+    str1b(:)[1] = ustr2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" &
+        .or. str1b(3) /= 1_"abc") call abort()
+  else
+    if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" &
+        .or. str1b(3) /= 1_"ZZZ") call abort()
+  end if
+
+  ! contiguous ARRAY - kind 4 <- 1 - with trimming
+  str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz"
+  str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
+  ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
+  str2a = 1_"abcdefg"
+  ustr1b(1) = 4_"XXX"
+  ustr1b(2) = 4_"YYY"
+  ustr1b(3) = 4_"ZZZ"
+  if (this_image() == num_images()) then
+    ustr1b(:)[1] = str2a[mod(1, num_images())+1]
+  end if
+  sync all
+  if (this_image() == 1) then
+    if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" &
+        .or. ustr1b(3) /= 4_"abc") call abort()
+  else
+    if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" &
+        .or. ustr1b(3) /= 4_"ZZZ") call abort()
+  end if
+
+end subroutine char_test
+end program test

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index ec8928df04e9965d51be664fc601646b56c07fba..7ae6d5ff22d0cad220427555e6e1ce7a4e35da29 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,9 @@
+2014-06-25  Tobias Burnus  <burnus@net-b.de>
+
+       * caf/single.c (assign_char4_from_char1, assign_char1_from_char4,
+       convert_type): New static functions.
+       (_gfortran_caf_get, _gfortran_caf_send): Use them.
+
 2014-06-19  Tobias Burnus  <burnus@net-b.de>
 
        * caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max,

diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index abb0a1fb9a28b00f3a75ae055917be2ab0505375..d053c50312985a56de057a8bf3c5718a7fc14a49 100644 (file)
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -236,6 +236,292 @@ _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
     *stat = 0;
 }
 
+
+static void
+assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
+                        unsigned char *src)
+{
+  size_t i, n;
+  n = dst_size/4 > src_size ? src_size : dst_size/4;
+  for (i = 0; i < n; ++i)
+    dst[i] = (int32_t) src[i];
+  for (; i < dst_size/4; ++i)
+    dst[i] = (int32_t) ' ';
+}
+
+
+static void
+assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
+                        uint32_t *src)
+{
+  size_t i, n;
+  n = dst_size > src_size/4 ? src_size/4 : dst_size;
+  for (i = 0; i < n; ++i)
+    dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
+  if (dst_size > n)
+    memset(&dst[n], ' ', dst_size - n);
+}
+
+
+static void
+convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
+             int src_kind)
+{
+#ifdef HAVE_GFC_INTEGER_16
+  typedef __int128 int128t;
+#else
+  typedef int64_t int128t;
+#endif
+
+#if defined(GFC_REAL_16_IS_LONG_DOUBLE)
+  typedef long double real128t;
+  typedef _Complex long double complex128t;
+#elif defined(HAVE_GFC_REAL_16)
+  typedef _Complex float __attribute__((mode(TC))) __complex128;
+  typedef __float128 real128t;
+  typedef __complex128 complex128t;
+#elif defined(HAVE_GFC_REAL_10)
+  typedef long double real128t;
+  typedef long double complex128t;
+#else
+  typedef double real128t;
+  typedef _Complex double complex128t;
+#endif
+
+  int128t int_val = 0;
+  real128t real_val = 0;
+  complex128t cmpx_val = 0;
+
+  switch (src_type)
+    {
+    case BT_INTEGER:
+      if (src_kind == 1)
+       int_val = *(int8_t*) src;
+      else if (src_kind == 2)
+       int_val = *(int16_t*) src;
+      else if (src_kind == 4)
+       int_val = *(int32_t*) src;
+      else if (src_kind == 8)
+       int_val = *(int64_t*) src;
+#ifdef HAVE_GFC_INTEGER_16
+      else if (src_kind == 16)
+       int_val = *(int128t*) src;
+#endif
+      else
+       goto error;
+      break;
+    case BT_REAL:
+      if (src_kind == 4)
+       real_val = *(float*) src;
+      else if (src_kind == 8)
+       real_val = *(double*) src;
+#ifdef HAVE_GFC_REAL_10
+      else if (src_kind == 10)
+       real_val = *(long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+      else if (src_kind == 16)
+       real_val = *(real128t*) src;
+#endif
+      else
+       goto error;
+      break;
+    case BT_COMPLEX:
+      if (src_kind == 4)
+       cmpx_val = *(_Complex float*) src;
+      else if (src_kind == 8)
+       cmpx_val = *(_Complex double*) src;
+#ifdef HAVE_GFC_REAL_10
+      else if (src_kind == 10)
+       cmpx_val = *(_Complex long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+      else if (src_kind == 16)
+       cmpx_val = *(complex128t*) src;
+#endif
+      else
+       goto error;
+      break;
+    default:
+      goto error;
+    }
+
+  switch (dst_type)
+    {
+    case BT_INTEGER:
+      if (src_type == BT_INTEGER)
+       {
+         if (dst_kind == 1)
+           *(int8_t*) dst = (int8_t) int_val;
+         else if (dst_kind == 2)
+           *(int16_t*) dst = (int16_t) int_val;
+         else if (dst_kind == 4)
+           *(int32_t*) dst = (int32_t) int_val;
+         else if (dst_kind == 8)
+           *(int64_t*) dst = (int64_t) int_val;
+#ifdef HAVE_GFC_INTEGER_16
+         else if (dst_kind == 16)
+           *(int128t*) dst = (int128t) int_val;
+#endif
+         else
+           goto error;
+       }
+      else if (src_type == BT_REAL)
+       {
+         if (dst_kind == 1)
+           *(int8_t*) dst = (int8_t) real_val;
+         else if (dst_kind == 2)
+           *(int16_t*) dst = (int16_t) real_val;
+         else if (dst_kind == 4)
+           *(int32_t*) dst = (int32_t) real_val;
+         else if (dst_kind == 8)
+           *(int64_t*) dst = (int64_t) real_val;
+#ifdef HAVE_GFC_INTEGER_16
+         else if (dst_kind == 16)
+           *(int128t*) dst = (int128t) real_val;
+#endif
+         else
+           goto error;
+       }
+      else if (src_type == BT_COMPLEX)
+       {
+         if (dst_kind == 1)
+           *(int8_t*) dst = (int8_t) cmpx_val;
+         else if (dst_kind == 2)
+           *(int16_t*) dst = (int16_t) cmpx_val;
+         else if (dst_kind == 4)
+           *(int32_t*) dst = (int32_t) cmpx_val;
+         else if (dst_kind == 8)
+           *(int64_t*) dst = (int64_t) cmpx_val;
+#ifdef HAVE_GFC_INTEGER_16
+         else if (dst_kind == 16)
+           *(int128t*) dst = (int128t) cmpx_val;
+#endif
+         else
+           goto error;
+       }
+      else
+       goto error;
+      break;
+    case BT_REAL:
+      if (src_type == BT_INTEGER)
+       {
+         if (dst_kind == 4)
+           *(float*) dst = (float) int_val;
+         else if (dst_kind == 8)
+           *(double*) dst = (double) int_val;
+#ifdef HAVE_GFC_REAL_10
+         else if (dst_kind == 10)
+           *(long double*) dst = (long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+         else if (dst_kind == 16)
+           *(real128t*) dst = (real128t) int_val;
+#endif
+         else
+           goto error;
+       }
+      else if (src_type == BT_REAL)
+       {
+         if (dst_kind == 4)
+           *(float*) dst = (float) real_val;
+         else if (dst_kind == 8)
+           *(double*) dst = (double) real_val;
+#ifdef HAVE_GFC_REAL_10
+         else if (dst_kind == 10)
+           *(long double*) dst = (long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+         else if (dst_kind == 16)
+           *(real128t*) dst = (real128t) real_val;
+#endif
+         else
+           goto error;
+       }
+      else if (src_type == BT_COMPLEX)
+       {
+         if (dst_kind == 4)
+           *(float*) dst = (float) cmpx_val;
+         else if (dst_kind == 8)
+           *(double*) dst = (double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+         else if (dst_kind == 10)
+           *(long double*) dst = (long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+         else if (dst_kind == 16)
+           *(real128t*) dst = (real128t) cmpx_val;
+#endif
+         else
+           goto error;
+       }
+      break;
+    case BT_COMPLEX:
+      if (src_type == BT_INTEGER)
+       {
+         if (dst_kind == 4)
+           *(_Complex float*) dst = (_Complex float) int_val;
+         else if (dst_kind == 8)
+           *(_Complex double*) dst = (_Complex double) int_val;
+#ifdef HAVE_GFC_REAL_10
+         else if (dst_kind == 10)
+           *(_Complex long double*) dst = (_Complex long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+         else if (dst_kind == 16)
+           *(complex128t*) dst = (complex128t) int_val;
+#endif
+         else
+           goto error;
+       }
+      else if (src_type == BT_REAL)
+       {
+         if (dst_kind == 4)
+           *(_Complex float*) dst = (_Complex float) real_val;
+         else if (dst_kind == 8)
+           *(_Complex double*) dst = (_Complex double) real_val;
+#ifdef HAVE_GFC_REAL_10
+         else if (dst_kind == 10)
+           *(_Complex long double*) dst = (_Complex long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+         else if (dst_kind == 16)
+           *(complex128t*) dst = (complex128t) real_val;
+#endif
+         else
+           goto error;
+       }
+      else if (src_type == BT_COMPLEX)
+       {
+         if (dst_kind == 4)
+           *(_Complex float*) dst = (_Complex float) cmpx_val;
+         else if (dst_kind == 8)
+           *(_Complex double*) dst = (_Complex double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+         else if (dst_kind == 10)
+           *(_Complex long double*) dst = (_Complex long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+         else if (dst_kind == 16)
+           *(complex128t*) dst = (complex128t) cmpx_val;
+#endif
+         else
+           goto error;
+       }
+      else
+       goto error;
+      break;
+    default:
+      goto error;
+    }
+
+error:
+  fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
+          "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
+  abort();
+}
+
+
 void
 _gfortran_caf_get (caf_token_t token, size_t offset,
                   int image_index __attribute__ ((unused)),
@@ -243,9 +529,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
                   caf_vector_t *src_vector __attribute__ ((unused)),
                   gfc_descriptor_t *dest, int src_kind, int dst_kind)
 {
-  /* FIXME: Handle vector subscript, type conversion and assignment "array = scalar".
-     check in particular whether strings of different kinds are permitted and
-     whether it makes sense to handle array = scalar.  */
+  /* FIXME: Handle vector subscripts.  */
   size_t i, k, size;
   int j;
   int rank = GFC_DESCRIPTOR_RANK (dest);
@@ -255,19 +539,30 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
   if (rank == 0)
     {
       void *sr = (void *) ((char *) TOKEN (token) + offset);
-      if (dst_kind == src_kind)
-       memmove (GFC_DESCRIPTOR_DATA (dest), sr,
-                dst_size > src_size ? src_size : dst_size);
-      /* else: FIXME: type conversion.  */
-      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+         && dst_kind == src_kind)
        {
-         if (dst_kind == 1)
-           memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size, ' ',
-                   dst_size-src_size);
-         else /* dst_kind == 4.  */
-           for (i = src_size/4; i < dst_size/4; i++)
-             ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t)' ';
+         memmove (GFC_DESCRIPTOR_DATA (dest), sr,
+                  dst_size > src_size ? src_size : dst_size);
+         if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+           {
+             if (dst_kind == 1)
+               memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
+                       ' ', dst_size - src_size);
+             else /* dst_kind == 4.  */
+               for (i = src_size/4; i < dst_size/4; i++)
+                 ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
+           }
        }
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+       assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
+                                sr);
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+       assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
+                                sr);
+      else
+       convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
+                     dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
       return;
     }
 
@@ -300,39 +595,42 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
       void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 
-      void *sr;
-      if (GFC_DESCRIPTOR_RANK (src) != 0)
+      ptrdiff_t array_offset_sr = 0;
+      stride = 1;
+      extent = 1;
+      for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
        {
-         ptrdiff_t array_offset_sr = 0;
-         stride = 1;
-         extent = 1;
-         for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
-           {
-             array_offset_sr += ((i / (extent*stride))
-                                 % (src->dim[j]._ubound
-                                    - src->dim[j].lower_bound + 1))
-                                * src->dim[j]._stride;
-             extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
-             stride = src->dim[j]._stride;
-           }
-         array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
-         sr = (void *)((char *) TOKEN (token) + offset
-                       + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+         array_offset_sr += ((i / (extent*stride))
+                              % (src->dim[j]._ubound
+                                 - src->dim[j].lower_bound + 1))
+                             * src->dim[j]._stride;
+         extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+         stride = src->dim[j]._stride;
        }
-      else
-       sr = (void *)((char *) TOKEN (token) + offset);
+      array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+      void *sr = (void *)((char *) TOKEN (token) + offset
+                         + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 
-      if (dst_kind == src_kind)
-       memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
-      /* else: FIXME: type conversion.  */
-      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+         && dst_kind == src_kind)
        {
-         if (dst_kind == 1)
-           memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
-         else /* dst_kind == 4.  */
-           for (k = src_size/4; k < dst_size/4; i++)
-             ((int32_t*) dst)[i] = (int32_t)' ';
+         memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
+         if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+           {
+             if (dst_kind == 1)
+               memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+             else /* dst_kind == 4.  */
+               for (k = src_size/4; k < dst_size/4; k++)
+                 ((int32_t*) dst)[k] = (int32_t) ' ';
+           }
        }
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+       assign_char1_from_char4 (dst_size, src_size, dst, sr);
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+       assign_char4_from_char1 (dst_size, src_size, dst, sr);
+      else
+       convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+                     sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
     }
 }
 
@@ -342,11 +640,9 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
                    int image_index __attribute__ ((unused)),
                    gfc_descriptor_t *dest,
                    caf_vector_t *dst_vector __attribute__ ((unused)),
-                   gfc_descriptor_t *src, int dst_kind,
-                   int src_kind __attribute__ ((unused)))
+                   gfc_descriptor_t *src, int dst_kind, int src_kind)
 {
-  /* FIXME: Handle vector subscript, type conversion and assignment "array = scalar".
-     check in particular whether strings of different kinds are permitted.  */
+  /* FIXME: Handle vector subscripts.  */
   size_t i, k, size;
   int j;
   int rank = GFC_DESCRIPTOR_RANK (dest);
@@ -356,18 +652,30 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
   if (rank == 0)
     {
       void *dst = (void *) ((char *) TOKEN (token) + offset);
-      if (dst_kind == src_kind)
-       memmove (dst, GFC_DESCRIPTOR_DATA (src),
-                dst_size > src_size ? src_size : dst_size);
-      /* else: FIXME: type conversion.  */
-      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+         && dst_kind == src_kind)
        {
-         if (dst_kind == 1)
-           memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
-         else /* dst_kind == 4.  */
-           for (i = src_size/4; i < dst_size/4; i++)
-             ((int32_t*) dst)[i] = (int32_t)' ';
+         memmove (dst, GFC_DESCRIPTOR_DATA (src),
+                  dst_size > src_size ? src_size : dst_size);
+         if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+           {
+             if (dst_kind == 1)
+               memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+             else /* dst_kind == 4.  */
+               for (i = src_size/4; i < dst_size/4; i++)
+                 ((int32_t*) dst)[i] = (int32_t) ' ';
+           }
        }
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+       assign_char1_from_char4 (dst_size, src_size, dst,
+                                GFC_DESCRIPTOR_DATA (src));
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+       assign_char4_from_char1 (dst_size, src_size, dst,
+                                GFC_DESCRIPTOR_DATA (src));
+      else
+       convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+                     GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
+                     src_kind);
       return;
     }
 
@@ -383,16 +691,6 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
   if (size == 0)
     return;
 
-#if 0
-  if (dst_len == src_len && PREFIX (is_contiguous) (dest)
-      && PREFIX (is_contiguous) (src))
-    {
-      void *dst = (void *)((char *) TOKEN (token) + offset);
-      memmove (dst, src->base_addr, GFC_DESCRIPTOR_SIZE (dest)*size);
-      return;
-    }
-#endif
-
   for (i = 0; i < size; i++)
     {
       ptrdiff_t array_offset_dst = 0;
@@ -432,17 +730,27 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
       else
        sr = src->base_addr;
 
-      if (dst_kind == src_kind)
-       memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
-      /* else: FIXME: type conversion.  */
-      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+         && dst_kind == src_kind)
        {
-         if (dst_kind == 1)
-           memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
-         else /* dst_kind == 4.  */
-           for (k = src_size/4; k < dst_size/4; i++)
-             ((int32_t*) dst)[i] = (int32_t)' ';
+         memmove (dst, sr,
+                  dst_size > src_size ? src_size : dst_size);
+         if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+           {
+             if (dst_kind == 1)
+               memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+             else /* dst_kind == 4.  */
+               for (k = src_size/4; k < dst_size/4; k++)
+                 ((int32_t*) dst)[k] = (int32_t) ' ';
+           }
        }
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+       assign_char1_from_char4 (dst_size, src_size, dst, sr);
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+       assign_char4_from_char1 (dst_size, src_size, dst, sr);
+      else
+       convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+                     sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
     }
 }