procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Fix class transformational intrinsic calls [PR102689]

Browse source 
2024-12-03  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/102689
	* trans-array.cc (get_array_ref_dim_for_loop_dim): Use the arg1
	class container carried in ss->info as the seed for a lhs in
	class valued transformational intrinsic calls that are not the
	rhs of an assignment. Otherwise, the lhs variable expression is
	taken from the loop chain. For this latter case, the _vptr and
	_len fields are set.
	(gfc_trans_create_temp_array): Use either the lhs expression
	seeds to build a class variable that will take the returned
	descriptor as its _data field. In the case that the arg1 expr.
	is used, 'atmp' must be marked as unused, a typespec built with
	the correct rank and the _vptr and _len fields set. The element
	size is provided for the temporary allocation and to set the
	descriptor span.
	(gfc_array_init_size): When an intrinsic type scalar expr3 is
	used in allocation of a class array, use its element size in
	the descriptor dtype.
	* trans-expr.cc (gfc_conv_class_to_class): Class valued
	transformational intrinsics return the pointer to the array
	descriptor as the _data field of a class temporary. Extract
	directly and return the address of the class temporary.
	(gfc_conv_procedure_call): store the expression for the first
	argument of a class valued transformational intrinsic function
	in the ss info class_container field. Later, use its type  as
	the element type in the call to gfc_trans_create_temp_array.
	(fcncall_realloc_result): Add a dtype argument and use it in
	the descriptor, when available.
	(gfc_trans_arrayfunc_assign): For class lhs, build a dtype with
	the lhs rank and the rhs element size and use it in the call to
	fcncall_realloc_result.

gcc/testsuite/
	PR fortran/102689
	* gfortran.dg/class_transformational_1.f90: New test for class-
	valued reshape.
	* gfortran.dg/class_transformational_2.f90: New test for other
	class_valued transformational intrinsics.
This commit is contained in:
Paul Thomas 2024-12-03 15:56:53 +00:00
parent 4114b7fb1c
commit 31250baf81
4 changed files with 490 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

157
gcc/fortran/trans-array.cc
View file

@ -1325,23 +1325,28 @@ 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)
get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
gfc_ss **fcnss)
{
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 rhs_class_expr = NULL_TREE;
tree 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
temporary; ie. the rhs of the assignment. */
rhs_ss = ss->loop->ss->loop_chain;
class temporary created in gfc_trans_create_temp_array. */
rhs_ss = loop_ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
@ -1350,28 +1355,58 @@ 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)
rhs_class_expr
class_expr
= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
else
rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
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! */
expression! Otherwise, the class container from arg1 can be used
to set the vptr and len fields of the result class container. */
lhs_ss = rhs_ss->loop_chain;
if (lhs_ss != gfc_ss_terminator
&& lhs_ss->info
&& lhs_ss->info->expr
if (lhs_ss && 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;
@ -1379,35 +1414,33 @@ 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 rhs_class_expr;
return class_expr;
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
/* Set the lhs vptr and, if necessary, the _len field. */
if (rhs_class_expr)
if (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 (rhs_class_expr)));
gfc_class_vptr_get (class_expr)));
if (unlimited_lhs)
{
gcc_assert (unlimited_rhs);
tmp = gfc_class_len_get (lhs_class_expr);
if (unlimited_rhs)
tmp2 = gfc_class_len_get (rhs_class_expr);
else
tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
tmp2 = gfc_class_len_get (class_expr);
gfc_add_modify (pre, tmp, tmp2);
}
if (rhs_function)
{
tmp = gfc_class_data_get (rhs_class_expr);
tmp = gfc_class_data_get (class_expr);
gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
}
}
else
else if (rhs_ss->info->data.array.descriptor)
{
/* lhs is class and rhs is intrinsic or derived type. */
*eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
@ -1435,7 +1468,7 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
}
}
return rhs_class_expr;
return class_expr;
}
@ -1476,6 +1509,7 @@ 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;
@ -1495,7 +1529,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);
class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
/* If the dynamic type is not available, use the declared type. */
if (eltype && GFC_CLASS_TYPE_P (eltype))
@ -1595,14 +1629,57 @@ 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)
if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
{
suppress_warning (desc);
TREE_USED (desc) = 0;
}
if (class_expr != NULL_TREE
|| (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
{
tree class_data;
tree dtype;
gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
/* Create a class temporary. */
tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
gfc_add_modify (pre, tmp, class_expr);
/* 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);
/* 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));
elemsize = gfc_resize_class_size_with_len (pre, class_expr,
elemsize);
}
elemsize = gfc_evaluate_now (elemsize, pre);
}
/* Assign the new descriptor to the _data field. This allows the
vptr _copy to be used for scalarized assignment since the class
@ -1612,11 +1689,25 @@ 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);
/* 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);
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);
/* 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;
}
@ -6073,6 +6164,14 @@ 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);

57
gcc/fortran/trans-expr.cc
View file

@ -1242,6 +1242,21 @@ 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;
@ -6490,7 +6505,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;
@ -6498,6 +6513,8 @@ 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);
@ -7601,6 +7618,19 @@ 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
@ -8211,6 +8241,7 @@ 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. */
@ -8495,8 +8526,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
argument is actually given. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
&& expr->value.function.isym
&& expr->value.function.isym->transformational
&& isym && isym->transformational
&& arg->expr
&& arg->expr->ts.type == BT_DERIVED
&& arg->expr->ts.u.derived->attr.alloc_comp)
@ -11495,7 +11525,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)
fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
{
tree desc;
tree res_desc;
@ -11514,7 +11544,10 @@ fcncall_realloc_result (gfc_se *se, int rank)
/* Unallocated, the descriptor does not have a dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (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)));
res_desc = gfc_evaluate_now (desc, &se->pre);
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
@ -11731,7 +11764,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
ss->is_alloc_lhs = 1;
}
else
fcncall_realloc_result (&se, expr1->rank);
{
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);
}
}
gfc_conv_function_expr (&se, expr2);

204
gcc/testsuite/gfortran.dg/class_transformational_1.f90 Normal file
View file

@ -0,0 +1,204 @@
! { dg-do run }
!
! Test transformational intrinsics with class results - PR102689
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
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)
if (allocated (src3)) deallocate (src3)
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
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)
if (allocated (src3)) deallocate (src3)
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

107
gcc/testsuite/gfortran.dg/class_transformational_2.f90 Normal file
View file

@ -0,0 +1,107 @@
! { 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 <pault@gcc.gnu.org>
!
type t
integer :: i
end type t
type, extends(t) :: s
integer :: j
end type
class(t), allocatable :: 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
deallocate (a, aa, b, c, field, ishape, ii, ij)
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
class default
stop stop_flag + 4
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
class default
stop stop_flag + 4
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
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