From 5c75088c80c2f661d435731dec5c3bc95376b9da Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Wed, 25 Jun 2014 22:31:32 +0200 Subject: [PATCH] resolve.c (resolve_ordinary_assign): Don't invoke caf_send when assigning a coindexed RHS scalar to a noncoindexed... 2014-06-25 Tobias Burnus 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 --- gcc/fortran/ChangeLog | 15 +- gcc/fortran/resolve.c | 5 +- gcc/fortran/trans-intrinsic.c | 8 + gcc/testsuite/ChangeLog | 4 + .../gfortran.dg/coarray/coindexed_1.f90 | 1459 +++++++++++++++++ libgfortran/ChangeLog | 6 + libgfortran/caf/single.c | 458 +++++- 7 files changed, 1876 insertions(+), 79 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 12606ffeaa8..d92a88f31a0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,10 +1,19 @@ +2014-06-25 Tobias Burnus + + * 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 * 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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 48b3a40f769..ca20c294243 100644 --- 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 a0c74218e63..a1dfdfb2f83 100644 --- 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 7046ff74105..0735c448cc1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2014-06-25 Tobias Burnus + + * gfortran.dg/coarray/coindexed_1.f90: New. + 2014-06-25 Tobias Burnus * 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 index 00000000000..86f86d1af2c --- /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 ec8928df04e..7ae6d5ff22d 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,9 @@ +2014-06-25 Tobias Burnus + + * 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 * caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max, diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index abb0a1fb9a2..d053c503129 100644 --- 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); } } -- 2.30.2