Skip to content

R
riscv-gcc-1
Commit 5c75088c by Tobias Burnus Committed by Tobias Burnus
Options

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

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

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
parent aa9ca5ca
Showing with 1876 additions and 79 deletions
gcc/fortran/ChangeLog
2014-06-25 Tobias Burnus <burnus@net-b.de> 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. * check.c (check_co_minmaxsum): Add definable check.
* expr.c (gfc_check_vardef_context): Fix context == NULL case. * expr.c (gfc_check_vardef_context): Fix context == NULL case.
* trans-expr.c (get_scalar_to_descriptor_type): Handle pointer arguments. * trans-expr.c (get_scalar_to_descriptor_type): Handle pointer
* trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Fix generation of temporary arguments.
strings. * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Fix generation of
temporary strings.
2014-06-25 Jakub Jelinek <jakub@redhat.com> 2014-06-25 Jakub Jelinek <jakub@redhat.com>
......
gcc/fortran/resolve.c
...@@ -9300,12 +9300,15 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) ...@@ -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. /* 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 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 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 if (gfc_option.coarray == GFC_FCOARRAY_LIB
&& (lhs_coindexed && (lhs_coindexed
|| (code->expr2->expr_type == EXPR_FUNCTION || (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym && code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
&& (code->expr1->rank == 0 || code->expr2->rank != 0)
&& !gfc_expr_attr (rhs).allocatable && !gfc_expr_attr (rhs).allocatable
&& !gfc_has_vector_subscript (rhs)))) && !gfc_has_vector_subscript (rhs))))
{ {
......
gcc/fortran/trans-intrinsic.c
...@@ -1349,6 +1349,7 @@ conv_caf_send (gfc_code *code) { ...@@ -1349,6 +1349,7 @@ conv_caf_send (gfc_code *code) {
gfc_se lhs_se, rhs_se; gfc_se lhs_se, rhs_se;
stmtblock_t block; stmtblock_t block;
tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; 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; tree vec = null_pointer_node, rhs_vec = null_pointer_node;
gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB); gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
...@@ -1364,6 +1365,7 @@ conv_caf_send (gfc_code *code) { ...@@ -1364,6 +1365,7 @@ conv_caf_send (gfc_code *code) {
symbol_attribute attr; symbol_attribute attr;
gfc_clear_attr (&attr); gfc_clear_attr (&attr);
gfc_conv_expr (&lhs_se, lhs_expr); 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_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
} }
...@@ -1385,6 +1387,7 @@ conv_caf_send (gfc_code *code) { ...@@ -1385,6 +1387,7 @@ conv_caf_send (gfc_code *code) {
} }
lhs_se.want_pointer = 1; lhs_se.want_pointer = 1;
gfc_conv_expr_descriptor (&lhs_se, lhs_expr); gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
lhs_type = gfc_get_element_type (TREE_TYPE (TREE_TYPE (lhs_se.expr)));
if (has_vector) if (has_vector)
{ {
vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar); vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar);
...@@ -1418,11 +1421,16 @@ conv_caf_send (gfc_code *code) { ...@@ -1418,11 +1421,16 @@ conv_caf_send (gfc_code *code) {
/* RHS. */ /* RHS. */
gfc_init_se (&rhs_se, NULL); 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) if (rhs_expr->rank == 0)
{ {
symbol_attribute attr; symbol_attribute attr;
gfc_clear_attr (&attr); gfc_clear_attr (&attr);
gfc_conv_expr (&rhs_se, rhs_expr); 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_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr); rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
} }
......
gcc/testsuite/ChangeLog
2014-06-25 Tobias Burnus <burnus@net-b.de> 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. * gfortran.dg/coarray_collectives_7.f90: New.
2014-06-25 Bernd Edlinger <bernd.edlinger@hotmail.de> 2014-06-25 Bernd Edlinger <bernd.edlinger@hotmail.de>
......
gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 0 → 100644
! { 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
libgfortran/ChangeLog
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> 2014-06-19 Tobias Burnus <burnus@net-b.de>
* caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max, * caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max,
......
libgfortran/caf/single.c
...@@ -236,6 +236,292 @@ _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)), ...@@ -236,6 +236,292 @@ _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
*stat = 0; *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 void
_gfortran_caf_get (caf_token_t token, size_t offset, _gfortran_caf_get (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)), int image_index __attribute__ ((unused)),
...@@ -243,9 +529,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset, ...@@ -243,9 +529,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
caf_vector_t *src_vector __attribute__ ((unused)), caf_vector_t *src_vector __attribute__ ((unused)),
gfc_descriptor_t *dest, int src_kind, int dst_kind) gfc_descriptor_t *dest, int src_kind, int dst_kind)
{ {
/* FIXME: Handle vector subscript, type conversion and assignment "array = scalar". /* FIXME: Handle vector subscripts. */
check in particular whether strings of different kinds are permitted and
whether it makes sense to handle array = scalar. */
size_t i, k, size; size_t i, k, size;
int j; int j;
int rank = GFC_DESCRIPTOR_RANK (dest); int rank = GFC_DESCRIPTOR_RANK (dest);
...@@ -255,19 +539,30 @@ _gfortran_caf_get (caf_token_t token, size_t offset, ...@@ -255,19 +539,30 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
if (rank == 0) if (rank == 0)
{ {
void *sr = (void *) ((char *) TOKEN (token) + offset); void *sr = (void *) ((char *) TOKEN (token) + offset);
if (dst_kind == src_kind) if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
memmove (GFC_DESCRIPTOR_DATA (dest), sr, && dst_kind == src_kind)
dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{ {
if (dst_kind == 1) memmove (GFC_DESCRIPTOR_DATA (dest), sr,
memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size, ' ', dst_size > src_size ? src_size : dst_size);
dst_size-src_size); if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
else /* dst_kind == 4. */ {
for (i = src_size/4; i < dst_size/4; i++) if (dst_kind == 1)
((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t)' '; 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; return;
} }
...@@ -300,39 +595,42 @@ _gfortran_caf_get (caf_token_t token, size_t offset, ...@@ -300,39 +595,42 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest); void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
void *sr; ptrdiff_t array_offset_sr = 0;
if (GFC_DESCRIPTOR_RANK (src) != 0) stride = 1;
extent = 1;
for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
{ {
ptrdiff_t array_offset_sr = 0; array_offset_sr += ((i / (extent*stride))
stride = 1; % (src->dim[j]._ubound
extent = 1; - src->dim[j].lower_bound + 1))
for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) * src->dim[j]._stride;
{ extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
array_offset_sr += ((i / (extent*stride)) stride = src->dim[j]._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));
} }
else array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
sr = (void *)((char *) TOKEN (token) + offset); void *sr = (void *)((char *) TOKEN (token) + offset
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
if (dst_kind == src_kind) if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
memmove (dst, sr, dst_size > src_size ? src_size : dst_size); && dst_kind == src_kind)
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{ {
if (dst_kind == 1) memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size); if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
else /* dst_kind == 4. */ {
for (k = src_size/4; k < dst_size/4; i++) if (dst_kind == 1)
((int32_t*) dst)[i] = (int32_t)' '; 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, ...@@ -342,11 +640,9 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)), int image_index __attribute__ ((unused)),
gfc_descriptor_t *dest, gfc_descriptor_t *dest,
caf_vector_t *dst_vector __attribute__ ((unused)), caf_vector_t *dst_vector __attribute__ ((unused)),
gfc_descriptor_t *src, int dst_kind, gfc_descriptor_t *src, int dst_kind, int src_kind)
int src_kind __attribute__ ((unused)))
{ {
/* FIXME: Handle vector subscript, type conversion and assignment "array = scalar". /* FIXME: Handle vector subscripts. */
check in particular whether strings of different kinds are permitted. */
size_t i, k, size; size_t i, k, size;
int j; int j;
int rank = GFC_DESCRIPTOR_RANK (dest); int rank = GFC_DESCRIPTOR_RANK (dest);
...@@ -356,18 +652,30 @@ _gfortran_caf_send (caf_token_t token, size_t offset, ...@@ -356,18 +652,30 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
if (rank == 0) if (rank == 0)
{ {
void *dst = (void *) ((char *) TOKEN (token) + offset); void *dst = (void *) ((char *) TOKEN (token) + offset);
if (dst_kind == src_kind) if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
memmove (dst, GFC_DESCRIPTOR_DATA (src), && dst_kind == src_kind)
dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{ {
if (dst_kind == 1) memmove (dst, GFC_DESCRIPTOR_DATA (src),
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size); dst_size > src_size ? src_size : dst_size);
else /* dst_kind == 4. */ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
for (i = src_size/4; i < dst_size/4; i++) {
((int32_t*) dst)[i] = (int32_t)' '; 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; return;
} }
...@@ -383,16 +691,6 @@ _gfortran_caf_send (caf_token_t token, size_t offset, ...@@ -383,16 +691,6 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
if (size == 0) if (size == 0)
return; 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++) for (i = 0; i < size; i++)
{ {
ptrdiff_t array_offset_dst = 0; ptrdiff_t array_offset_dst = 0;
...@@ -432,17 +730,27 @@ _gfortran_caf_send (caf_token_t token, size_t offset, ...@@ -432,17 +730,27 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
else else
sr = src->base_addr; sr = src->base_addr;
if (dst_kind == src_kind) if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
memmove (dst, sr, dst_size > src_size ? src_size : dst_size); && dst_kind == src_kind)
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{ {
if (dst_kind == 1) memmove (dst, sr,
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size); dst_size > src_size ? src_size : dst_size);
else /* dst_kind == 4. */ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
for (k = src_size/4; k < dst_size/4; i++) {
((int32_t*) dst)[i] = (int32_t)' '; 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);
} }
} }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment