From f9f599a44e3156a5f5679adc048ec6ff2f44cc0e Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 23 Aug 2024 13:16:53 +0100 Subject: [PATCH] Revert "Fortran: Fix class transformational intrinsic calls [PR102689]" This reverts commit 4cb07a38233aadb4b389a6e5236c95f52241b6e0. --- gcc/fortran/trans-array.cc | 146 +++---------- gcc/fortran/trans-expr.cc | 57 +---- .../gfortran.dg/class_transformational_1.f90 | 204 ------------------ .../gfortran.dg/class_transformational_2.f90 | 103 --------- 4 files changed, 35 insertions(+), 475 deletions(-) delete mode 100644 gcc/testsuite/gfortran.dg/class_transformational_1.f90 delete mode 100644 gcc/testsuite/gfortran.dg/class_transformational_2.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index ea5fff2e0c2..8c35926436d 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1301,28 +1301,23 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) is a class expression. */ static tree -get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, - gfc_ss **fcnss) +get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) { - gfc_ss *loop_ss = ss->loop->ss; gfc_ss *lhs_ss; gfc_ss *rhs_ss; - gfc_ss *fcn_ss = NULL; tree tmp; tree tmp2; tree vptr; - tree class_expr = NULL_TREE; + tree rhs_class_expr = NULL_TREE; tree lhs_class_expr = NULL_TREE; bool unlimited_rhs = false; bool unlimited_lhs = false; bool rhs_function = false; - bool unlimited_arg1 = false; gfc_symbol *vtab; - tree cntnr = NULL_TREE; /* The second element in the loop chain contains the source for the - class temporary created in gfc_trans_create_temp_array. */ - rhs_ss = loop_ss->loop_chain; + temporary; ie. the rhs of the assignment. */ + rhs_ss = ss->loop->ss->loop_chain; if (rhs_ss != gfc_ss_terminator && rhs_ss->info @@ -1331,58 +1326,28 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, && rhs_ss->info->data.array.descriptor) { if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE) - class_expr + rhs_class_expr = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor); else - class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr); + rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr); unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr); if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION) rhs_function = true; } - /* Usually, ss points to the function. When the function call is an actual - argument, it is instead rhs_ss because the ss chain is shifted by one. */ - *fcnss = fcn_ss = rhs_function ? rhs_ss : ss; - - /* If this is a transformational function with a class result, the info - class_container field points to the class container of arg1. */ - if (class_expr != NULL_TREE - && fcn_ss->info && fcn_ss->info->expr - && fcn_ss->info->expr->expr_type == EXPR_FUNCTION - && fcn_ss->info->expr->value.function.isym - && fcn_ss->info->expr->value.function.isym->transformational) - { - cntnr = ss->info->class_container; - unlimited_arg1 - = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr); - } - /* For an assignment the lhs is the next element in the loop chain. If we have a class rhs, this had better be a class variable - expression! Otherwise, the class container from arg1 can be used - to set the vptr and len fields of the result class container. */ + expression! */ lhs_ss = rhs_ss->loop_chain; - if (lhs_ss && lhs_ss != gfc_ss_terminator - && lhs_ss->info && lhs_ss->info->expr + if (lhs_ss != gfc_ss_terminator + && lhs_ss->info + && lhs_ss->info->expr && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE && lhs_ss->info->expr->ts.type == BT_CLASS) { tmp = lhs_ss->info->data.array.descriptor; unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr); } - else if (cntnr != NULL_TREE) - { - tmp = gfc_class_vptr_get (class_expr); - gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp), - gfc_class_vptr_get (cntnr))); - if (unlimited_rhs) - { - tmp = gfc_class_len_get (class_expr); - if (unlimited_arg1) - gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr)); - } - tmp = NULL_TREE; - } else tmp = NULL_TREE; @@ -1390,33 +1355,35 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator) lhs_class_expr = gfc_get_class_from_expr (tmp); else - return class_expr; + return rhs_class_expr; gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr))); /* Set the lhs vptr and, if necessary, the _len field. */ - if (class_expr) + if (rhs_class_expr) { /* Both lhs and rhs are class expressions. */ tmp = gfc_class_vptr_get (lhs_class_expr); gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp), - gfc_class_vptr_get (class_expr))); + gfc_class_vptr_get (rhs_class_expr))); if (unlimited_lhs) { - gcc_assert (unlimited_rhs); tmp = gfc_class_len_get (lhs_class_expr); - tmp2 = gfc_class_len_get (class_expr); + if (unlimited_rhs) + tmp2 = gfc_class_len_get (rhs_class_expr); + else + tmp2 = build_int_cst (TREE_TYPE (tmp), 0); gfc_add_modify (pre, tmp, tmp2); } if (rhs_function) { - tmp = gfc_class_data_get (class_expr); + tmp = gfc_class_data_get (rhs_class_expr); gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); } } - else if (rhs_ss->info->data.array.descriptor) + else { /* lhs is class and rhs is intrinsic or derived type. */ *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor); @@ -1444,7 +1411,7 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, } } - return class_expr; + return rhs_class_expr; } @@ -1485,7 +1452,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, tree or_expr; tree elemsize; tree class_expr = NULL_TREE; - gfc_ss *fcn_ss = NULL; int n, dim, tmp_dim; int total_dim = 0; @@ -1505,7 +1471,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, The descriptor can be obtained from the ss->info and then converted to the class object. */ if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype)) - class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss); + class_expr = get_class_info_from_ss (pre, ss, &eltype); /* If the dynamic type is not available, use the declared type. */ if (eltype && GFC_CLASS_TYPE_P (eltype)) @@ -1605,46 +1571,14 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, gfc_add_expr_to_block (pre, build1 (DECL_EXPR, arraytype, TYPE_NAME (arraytype))); - if (class_expr != NULL_TREE - || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)) + if (class_expr != NULL_TREE) { tree class_data; tree dtype; - gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL; - /* Create a class temporary for the result using the lhs class object. */ - if (class_expr != NULL_TREE) - { - tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); - gfc_add_modify (pre, tmp, class_expr); - } - else - { - tree vptr; - class_expr = fcn_ss->info->class_container; - gcc_assert (expr1); - - /* Build a new class container using the arg1 class object. The class - typespec must be rebuilt because the rank might have changed. */ - gfc_typespec ts = CLASS_DATA (expr1)->ts; - symbol_attribute attr = CLASS_DATA (expr1)->attr; - gfc_change_class (&ts, &attr, NULL, expr1->rank, 0); - tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp"); - fcn_ss->info->class_container = tmp; - - /* Set the vptr and obtain the element size. */ - vptr = gfc_class_vptr_get (tmp); - gfc_add_modify (pre, vptr, - fold_convert (TREE_TYPE (vptr), - gfc_class_vptr_get (class_expr))); - elemsize = gfc_class_vtab_size_get (class_expr); - elemsize = gfc_evaluate_now (elemsize, pre); - - /* Set the _len field, if necessary. */ - if (UNLIMITED_POLY (expr1)) - gfc_add_modify (pre, gfc_class_len_get (tmp), - gfc_class_len_get (class_expr)); - } + /* Create a class temporary. */ + tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); + gfc_add_modify (pre, tmp, class_expr); /* Assign the new descriptor to the _data field. This allows the vptr _copy to be used for scalarized assignment since the class @@ -1654,25 +1588,11 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, TREE_TYPE (desc), desc); gfc_add_modify (pre, class_data, tmp); - if (expr1 && expr1->expr_type == EXPR_FUNCTION - && expr1->value.function.isym - && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE - || expr1->value.function.isym->id == GFC_ISYM_UNPACK)) - { - /* Take the dtype from the class expression. */ - dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); - tmp = gfc_conv_descriptor_dtype (class_data); - gfc_add_modify (pre, tmp, dtype); + /* Take the dtype from the class expression. */ + dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); + tmp = gfc_conv_descriptor_dtype (class_data); + gfc_add_modify (pre, tmp, dtype); - /* Transformational functions reshape and reduce can change the rank. */ - if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container) - { - tmp = gfc_conv_descriptor_rank (class_data); - gfc_add_modify (pre, tmp, - build_int_cst (TREE_TYPE (tmp), ss->loop->dimen)); - fcn_ss->info->class_container = NULL_TREE; - } - } /* Point desc to the class _data field. */ desc = class_data; } @@ -6070,14 +5990,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = gfc_conv_descriptor_dtype (descriptor); gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc)); } - else if (expr->ts.type == BT_CLASS - && expr3 && expr3->ts.type != BT_CLASS - && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE) - { - tmp = gfc_conv_descriptor_elem_len (descriptor); - gfc_add_modify (pblock, tmp, - fold_convert (TREE_TYPE (tmp), expr3_elem_size)); - } else { tmp = gfc_conv_descriptor_dtype (descriptor); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 8801a15c3a8..909cdeb4e59 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1231,21 +1231,6 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, stmtblock_t block; bool full_array = false; - /* Class transformational function results are the data field of a class - temporary and so the class expression can be obtained directly. */ - if (e->expr_type == EXPR_FUNCTION - && e->value.function.isym - && e->value.function.isym->transformational - && TREE_CODE (parmse->expr) == COMPONENT_REF - && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))) - { - parmse->expr = TREE_OPERAND (parmse->expr, 0); - if (!VAR_P (parmse->expr)) - parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre); - parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); - return; - } - gfc_init_block (&block); class_ref = NULL; @@ -6354,7 +6339,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_component *comp = NULL; int arglen; unsigned int argc; - tree arg1_cntnr = NULL_TREE; + arglist = NULL; retargs = NULL; stringargs = NULL; @@ -6362,8 +6347,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, var = NULL_TREE; len = NULL_TREE; gfc_clear_ts (&ts); - gfc_intrinsic_sym *isym = expr && expr->rank ? - expr->value.function.isym : NULL; comp = gfc_get_proc_ptr_comp (expr); @@ -7458,19 +7441,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, e->representation.length); } - /* Make the class container for the first argument available with class - valued transformational functions. */ - if (argc == 0 && e && e->ts.type == BT_CLASS - && isym && isym->transformational - && se->ss && se->ss->info) - { - arg1_cntnr = parmse.expr; - if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr))) - arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr); - arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr); - se->ss->info->class_container = arg1_cntnr; - } - if (fsym && e) { /* Obtain the character length of an assumed character length @@ -8072,7 +8042,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Set the type of the array. */ tmp = gfc_typenode_for_spec (&ts); - tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp; gcc_assert (se->ss->dimen == se->loop->dimen); /* Evaluate the bounds of the result, if known. */ @@ -8353,7 +8322,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, argument is actually given. */ arg = expr->value.function.actual; if (result && arg && expr->rank - && isym && isym->transformational + && expr->value.function.isym + && expr->value.function.isym->transformational && arg->expr && arg->expr->ts.type == BT_DERIVED && arg->expr->ts.u.derived->attr.alloc_comp) @@ -11329,7 +11299,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss, result to the original descriptor. */ static void -fcncall_realloc_result (gfc_se *se, int rank, tree dtype) +fcncall_realloc_result (gfc_se *se, int rank) { tree desc; tree res_desc; @@ -11348,10 +11318,7 @@ fcncall_realloc_result (gfc_se *se, int rank, tree dtype) /* Unallocated, the descriptor does not have a dtype. */ tmp = gfc_conv_descriptor_dtype (desc); - if (dtype != NULL_TREE) - gfc_add_modify (&se->pre, tmp, dtype); - else - gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); res_desc = gfc_evaluate_now (desc, &se->pre); gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); @@ -11568,19 +11535,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) ss->is_alloc_lhs = 1; } else - { - tree dtype = NULL_TREE; - tree type = gfc_typenode_for_spec (&expr2->ts); - if (expr1->ts.type == BT_CLASS) - { - tmp = gfc_class_vptr_get (sym->backend_decl); - tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); - tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); - gfc_add_modify (&se.pre, tmp, tmp2); - dtype = gfc_get_dtype_rank_type (expr1->rank,type); - } - fcncall_realloc_result (&se, expr1->rank, dtype); - } + fcncall_realloc_result (&se, expr1->rank); } gfc_conv_function_expr (&se, expr2); diff --git a/gcc/testsuite/gfortran.dg/class_transformational_1.f90 b/gcc/testsuite/gfortran.dg/class_transformational_1.f90 deleted file mode 100644 index 375e011b9f5..00000000000 --- a/gcc/testsuite/gfortran.dg/class_transformational_1.f90 +++ /dev/null @@ -1,204 +0,0 @@ -! { dg-do run } -! -! Test transformational intrinsics with class results - PR102689 -! -! Contributed by Tobias Burnus -! -module tests - type t - integer :: i - end type t - type, extends(t) :: s - integer :: j - end type - -contains - - subroutine class_bar(x) - class(*), intent(in) :: x(..) - integer :: checksum - - if (product (shape (x)) .ne. 10) stop 1 - select rank (x) - rank (1) - select type (x) - type is (s) - if (sum(x%i) .ne. 55) stop 2 - if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 3 - type is (character(*)) - checksum = sum(ichar(x(:)(1:1)) + ichar(x(:)(2:2))) - if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 4 - class default - stop - end select - rank (2) - select type (x) - type is (s) - if (sum(x%i) .ne. 55) stop 5 - if (sum(x%j) .ne. 550) stop 6 - type is (character(*)); - checksum = sum(ichar(x(:,:)(1:1)) + ichar(x(:,:)(2:2))) - if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 7 - class default - stop 8 - end select - rank (3) - select type (x) - type is (s) - if (sum(x%i) .ne. 55) stop 9 - if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 10 - type is (character(*)) - checksum = sum(ichar(x(:,:,:)(1:1)) + ichar(x(:,:,:)(2:2))) - if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 11 - class default - stop 12 - end select - end select - end -end module tests - -Module class_tests - use tests - implicit none - private - public :: test_class - - integer :: j - integer :: src(10) - type (s), allocatable :: src3 (:,:,:) - class(t), allocatable :: B(:,:,:), D(:) - -! gfortran gave type(t) for D for all these test cases. -contains - - subroutine test_class - - src3 = reshape ([(s(j,j*10), j=1,10)], [1,10,1]) - call test1 ! Now D OK for gfc15. B OK back to gfc10 - call foo - - call class_rebar(reshape(B, [10])) ! This is the original failure - run time segfault - - deallocate (B, D) - - allocate(B(2,1,5), source = s(1,11)) ! B was OK but descriptor elem_len = 4 so.... - src = [(j, j=1,10)] - call test2 ! D%j was type(t) and filled with B[1:5] - call foo - deallocate (B,D) - - call test3 ! B is set to type(t) and filled with [s(1,11)..s(5,50)] - call foo - deallocate (B,D) - - B = src3 ! Now D was like B in test3. B OK back to gfc10 - call foo - deallocate (B, D) - end - - subroutine class_rebar (arg) - class(t) :: arg(:) - call class_bar (arg) - end - - subroutine test1 - allocate(B, source = src3) - end - - subroutine test2 - B%i = RESHAPE(src, shape(B)) - end - - subroutine test3 - B = reshape ([(s(j,j*10), j=1,10)], shape(B)) - end - - subroutine foo - D = reshape(B, [10]) - call class_bar(B) - call class_bar(D) - end -end module class_tests - -module unlimited_tests - use tests - implicit none - private - public :: test_unlimited - - integer :: j - integer :: src(10) - character(len = 2, kind = 1) :: chr(10) - character(len = 2, kind = 1) :: chr3(5, 2, 1) - type (s), allocatable :: src3 (:,:,:) - class(*), allocatable :: B(:,:,:), D(:) - -contains - subroutine test_unlimited - call test1 - call foo - - call unlimited_rebar(reshape(B, [10])) ! Unlimited version of the original failure - - deallocate (B, D) - - call test3 - call foo - deallocate (B,D) - - B = src3 - call foo - deallocate (B, D) - - B = reshape ([(char(64 + 2*j - 1)//char(64 + 2*j), j = 1,10)], [5, 1, 2]) - call foo - deallocate (B, D) - - chr = [(char(96 + 2*j - 1)//char(96 + 2*j), j = 1,10)] - B = reshape (chr, [5, 1, 2]) - call foo - - call unlimited_rebar(reshape(B, [10])) ! Unlimited/ character version of the original failure - - deallocate (B, D) - - chr3 = reshape (chr, shape(chr3)) - B = chr3 - call foo - deallocate (B, D) - end - - subroutine unlimited_rebar (arg) - class(*) :: arg(:) - call class_bar (arg) - end - - subroutine test1 - src3 = reshape ([(s(j,j*10), j=1,10)], [2,1,5]) - allocate(B, source = src3) - end - - subroutine test3 - B = reshape ([(s(j,j*10), j=1,10)], shape(B)) - end - - subroutine foo - D = reshape(B, [10]) - call class_bar(B) - call class_bar(D) - end - -end module unlimited_tests - - call t1 - call t2 -contains - subroutine t1 - use class_tests - call test_class - end - subroutine t2 - use unlimited_tests - call test_unlimited - end -end diff --git a/gcc/testsuite/gfortran.dg/class_transformational_2.f90 b/gcc/testsuite/gfortran.dg/class_transformational_2.f90 deleted file mode 100644 index 908758b7548..00000000000 --- a/gcc/testsuite/gfortran.dg/class_transformational_2.f90 +++ /dev/null @@ -1,103 +0,0 @@ -! { dg-do run } -! -! Test transformational intrinsics other than reshape with class results. -! This emerged from PR102689, for which class_transformational_1.f90 tests -! class-valued reshape. -! -! Contributed by Paul Thomas -! - type t - integer :: i - end type t - type, extends(t) :: s - integer :: j - end type - class(t), allocatable :: scalar, a(:), aa(:), b(:,:), c(:,:,:), field(:,:,:) - integer, allocatable :: ishape(:), ii(:), ij(:) - logical :: la(2), lb(2,2), lc (4,2,2) - integer :: j, stop_flag - - call check_spread - call check_pack - call check_unpack - call check_eoshift - call check_eoshift_dep -contains - subroutine check_result_a (shift) - type (s), allocatable :: ss(:) - integer :: shift - select type (aa) - type is (s) - ss = eoshift (aa, shift = shift, boundary = aa(1), dim = 1) - ishape = shape (aa); - ii = ss%i - ij = ss%j - end select - if (any (ishape .ne. shape (a))) stop stop_flag + 1 - select type (a) - type is (s) - if (any (a%i .ne. ii)) stop stop_flag + 2 - if (any (a%j .ne. ij)) stop stop_flag + 3 - end select - end - - subroutine check_result - if (any (shape (c) .ne. ishape)) stop stop_flag + 1 - select type (a) - type is (s) - if (any (a%i .ne. ii)) stop stop_flag + 2 - if (any (a%j .ne. ij)) stop stop_flag + 3 - end select - end - - subroutine check_spread - stop_flag = 10 - a = [(s(j,10*j), j = 1,2)] - b = spread (a, dim = 2, ncopies = 2) - c = spread (b, dim = 1, ncopies = 4) - a = reshape (c, [size (c)]) - ishape = [4,2,2] - ii = [1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2] - ij = 10*[1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2] - call check_result - end - - subroutine check_pack - stop_flag = 20 - la = [.false.,.true.] - lb = spread (la, dim = 2, ncopies = 2) - lc = spread (lb, dim = 1, ncopies = 4) - a = pack (c, mask = lc) - ishape = shape (lc) - ii = [2,2,2,2,2,2,2,2] - ij = 10*[2,2,2,2,2,2,2,2] - call check_result - end - - subroutine check_unpack - stop_flag = 30 - a = [(s(j,10*j), j = 1,16)] - field = reshape ([(s(100*j,1000*j), j = 1,16)], shape(lc)) - c = unpack (a, mask = lc, field = field) - a = reshape (c, [product (shape (lc))]) - ishape = shape (lc) - ii = [100,200,300,400,1,2,3,4,900,1000,1100,1200,5,6,7,8] - ij = [1000,2000,3000,4000,10,20,30,40,9000,10000, 11000,12000,50,60,70,80] - call check_result - end - - subroutine check_eoshift - type (s), allocatable :: ss(:) - stop_flag = 40 - aa = a - a = eoshift (aa, shift = 3, boundary = aa(1), dim = 1) - call check_result_a (3) - end - - subroutine check_eoshift_dep - stop_flag = 50 - aa = a - a = eoshift (a, shift = -3, boundary = a(1), dim = 1) - call check_result_a (-3) - end -end