OpenMP/Fortran: Handle polymorphic scalars in data-sharing FIRSTPRIVATE [PR86470]
gcc/fortran/ChangeLog: PR fortran/86470 * trans-expr.c (gfc_copy_class_to_class): Add unshare_expr. * trans-openmp.c (gfc_is_polymorphic_nonptr, gfc_is_unlimited_polymorphic_nonptr): New. (gfc_omp_clause_copy_ctor, gfc_omp_clause_dtor): Handle polymorphic scalars. libgomp/ChangeLog: PR fortran/86470 * testsuite/libgomp.fortran/class-firstprivate-1.f90: New test. * testsuite/libgomp.fortran/class-firstprivate-2.f90: New test. * testsuite/libgomp.fortran/class-firstprivate-3.f90: New test. gcc/testsuite/ChangeLog: PR fortran/86470 * gfortran.dg/gomp/class-firstprivate-1.f90: New test. * gfortran.dg/gomp/class-firstprivate-2.f90: New test. * gfortran.dg/gomp/class-firstprivate-3.f90: New test. * gfortran.dg/gomp/class-firstprivate-4.f90: New test.
This commit is contained in:
Tobias Burnus
parent
b326f49521
commit
0e3b3b77e1
@ -1561,7 +1561,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
|
||||
{
|
||||
vec_safe_push (args, from_len);
|
||||
vec_safe_push (args, to_len);
|
||||
extcopy = build_call_vec (fcn_type, fcn, args);
|
||||
extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
|
||||
tmp = fold_build2_loc (input_location, GT_EXPR,
|
||||
logical_type_node, from_len,
|
||||
build_zero_cst (TREE_TYPE (from_len)));
|
||||
|
||||
@ -360,6 +360,39 @@ gfc_has_alloc_comps (tree type, tree decl)
|
||||
return false;
|
||||
}
|
||||
|
||||
/* Return true if TYPE is polymorphic but not with pointer attribute. */
|
||||
|
||||
static bool
|
||||
gfc_is_polymorphic_nonptr (tree type)
|
||||
{
|
||||
if (POINTER_TYPE_P (type))
|
||||
type = TREE_TYPE (type);
|
||||
return GFC_CLASS_TYPE_P (type);
|
||||
}
|
||||
|
||||
/* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
|
||||
unlimited means also intrinsic types are handled and _len is used. */
|
||||
|
||||
static bool
|
||||
gfc_is_unlimited_polymorphic_nonptr (tree type)
|
||||
{
|
||||
if (POINTER_TYPE_P (type))
|
||||
type = TREE_TYPE (type);
|
||||
if (!GFC_CLASS_TYPE_P (type))
|
||||
return false;
|
||||
|
||||
tree field = TYPE_FIELDS (type); /* _data */
|
||||
gcc_assert (field);
|
||||
field = DECL_CHAIN (field); /* _vptr */
|
||||
gcc_assert (field);
|
||||
field = DECL_CHAIN (field);
|
||||
if (!field)
|
||||
return false;
|
||||
gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0);
|
||||
return true;
|
||||
}
|
||||
|
||||
|
||||
/* Return true if DECL in private clause needs
|
||||
OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
|
||||
bool
|
||||
@ -743,12 +776,88 @@ tree
|
||||
gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
|
||||
{
|
||||
tree type = TREE_TYPE (dest), ptr, size, call;
|
||||
tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
|
||||
tree cond, then_b, else_b;
|
||||
stmtblock_t block, cond_block;
|
||||
|
||||
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
|
||||
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
|
||||
|
||||
if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
|
||||
&& DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
|
||||
&& GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
|
||||
decl_type
|
||||
= TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
|
||||
|
||||
if (gfc_is_polymorphic_nonptr (decl_type))
|
||||
{
|
||||
if (POINTER_TYPE_P (decl_type))
|
||||
decl_type = TREE_TYPE (decl_type);
|
||||
decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
|
||||
if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
|
||||
fatal_error (input_location,
|
||||
"Sorry, polymorphic arrays not yet supported for "
|
||||
"firstprivate");
|
||||
tree src_len;
|
||||
tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */
|
||||
tree src_data = gfc_class_data_get (unshare_expr (src));
|
||||
tree dest_data = gfc_class_data_get (unshare_expr (dest));
|
||||
bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type);
|
||||
|
||||
gfc_start_block (&block);
|
||||
gfc_add_modify (&block, gfc_class_vptr_get (dest),
|
||||
gfc_class_vptr_get (src));
|
||||
gfc_init_block (&cond_block);
|
||||
|
||||
if (unlimited)
|
||||
{
|
||||
src_len = gfc_class_len_get (src);
|
||||
gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len);
|
||||
}
|
||||
|
||||
/* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */
|
||||
size = fold_convert (size_type_node, gfc_class_vtab_size_get (src));
|
||||
if (unlimited)
|
||||
{
|
||||
cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
|
||||
unshare_expr (src_len),
|
||||
build_zero_cst (TREE_TYPE (src_len)));
|
||||
cond = build3_loc (input_location, COND_EXPR, size_type_node, cond,
|
||||
fold_convert (size_type_node,
|
||||
unshare_expr (src_len)),
|
||||
build_int_cst (size_type_node, 1));
|
||||
size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
|
||||
size, cond);
|
||||
}
|
||||
|
||||
/* Malloc memory + call class->_vpt->_copy. */
|
||||
call = builtin_decl_explicit (BUILT_IN_MALLOC);
|
||||
call = build_call_expr_loc (input_location, call, 1, size);
|
||||
gfc_add_modify (&cond_block, dest_data,
|
||||
fold_convert (TREE_TYPE (dest_data), call));
|
||||
gfc_add_expr_to_block (&cond_block,
|
||||
gfc_copy_class_to_class (src, dest, nelems,
|
||||
unlimited));
|
||||
|
||||
gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF);
|
||||
if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1)))
|
||||
{
|
||||
gfc_add_block_to_block (&block, &cond_block);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Create: if (class._data != 0) <cond_block> else class._data = NULL; */
|
||||
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||||
src_data, null_pointer_node);
|
||||
gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
|
||||
void_type_node, cond,
|
||||
gfc_finish_block (&cond_block),
|
||||
fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
||||
unshare_expr (dest_data), null_pointer_node)));
|
||||
}
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
|
||||
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|
||||
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
||||
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|
||||
@ -773,7 +882,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
|
||||
|
||||
gfc_init_block (&cond_block);
|
||||
|
||||
gfc_add_modify (&cond_block, dest, src);
|
||||
gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src));
|
||||
if (GFC_DESCRIPTOR_TYPE_P (type))
|
||||
{
|
||||
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
||||
@ -1185,6 +1294,57 @@ tree
|
||||
gfc_omp_clause_dtor (tree clause, tree decl)
|
||||
{
|
||||
tree type = TREE_TYPE (decl), tem;
|
||||
tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
|
||||
|
||||
if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
|
||||
&& DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
|
||||
&& GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
|
||||
decl_type
|
||||
= TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
|
||||
if (gfc_is_polymorphic_nonptr (decl_type))
|
||||
{
|
||||
if (POINTER_TYPE_P (decl_type))
|
||||
decl_type = TREE_TYPE (decl_type);
|
||||
decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
|
||||
if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
|
||||
fatal_error (input_location,
|
||||
"Sorry, polymorphic arrays not yet supported for "
|
||||
"firstprivate");
|
||||
stmtblock_t block, cond_block;
|
||||
gfc_start_block (&block);
|
||||
gfc_init_block (&cond_block);
|
||||
tree final = gfc_class_vtab_final_get (decl);
|
||||
tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl));
|
||||
gfc_se se;
|
||||
gfc_init_se (&se, NULL);
|
||||
symbol_attribute attr = {};
|
||||
tree data = gfc_class_data_get (decl);
|
||||
tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr);
|
||||
|
||||
/* Call class->_vpt->_finalize + free. */
|
||||
tree call = build_fold_indirect_ref (final);
|
||||
call = build_call_expr_loc (input_location, call, 3,
|
||||
gfc_build_addr_expr (NULL, desc),
|
||||
size, boolean_false_node);
|
||||
gfc_add_block_to_block (&cond_block, &se.pre);
|
||||
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
|
||||
gfc_add_block_to_block (&cond_block, &se.post);
|
||||
/* Create: if (_vtab && _final) <cond_block> */
|
||||
tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||||
gfc_class_vptr_get (decl),
|
||||
null_pointer_node);
|
||||
tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||||
final, null_pointer_node);
|
||||
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
|
||||
boolean_type_node, cond, cond2);
|
||||
gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
|
||||
void_type_node, cond,
|
||||
gfc_finish_block (&cond_block), NULL_TREE));
|
||||
call = builtin_decl_explicit (BUILT_IN_FREE);
|
||||
call = build_call_expr_loc (input_location, call, 1, data);
|
||||
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
|
||||
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|
||||
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
||||
|
||||
62
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90
Normal file
62
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-1.f90
Normal file
@ -0,0 +1,62 @@
|
||||
! { dg-do compile }
|
||||
! { dg-prune-output "compilation terminated." }
|
||||
!
|
||||
! FIRSTPRIVATE + class array
|
||||
!
|
||||
! For now: Expected to give "Sorry" for polymorphic arrays.
|
||||
!
|
||||
! Polymorphic arrays are tricky - at least if not allocatable, they become:
|
||||
! var.0 = var._data.data
|
||||
! which needs to be handled properly.
|
||||
!
|
||||
!
|
||||
program select_type_openmp
|
||||
use iso_c_binding
|
||||
!use omp_lib
|
||||
implicit none
|
||||
integer :: i
|
||||
integer :: A(4)
|
||||
type(c_ptr) :: B(4)
|
||||
|
||||
B = [(c_null_ptr, i=1,4)]
|
||||
A = [1,2,3,4]
|
||||
call sub(A, B)
|
||||
contains
|
||||
subroutine sub(val1, val2)
|
||||
class(*) :: val1(4)
|
||||
type(c_ptr) :: val2(2:5)
|
||||
|
||||
!$OMP PARALLEL firstprivate(val2)
|
||||
do i = 2, 5
|
||||
if (c_associated (val2(i))) stop 123
|
||||
end do
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 33
|
||||
if (any (val1 /= [1, 2, 3, 4])) stop 4549
|
||||
val1 = [32,6,48,28]
|
||||
class default
|
||||
stop 99
|
||||
end select
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 33
|
||||
if (any (val1 /= [32,6,48,28])) stop 4512
|
||||
class default
|
||||
stop 99
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 33
|
||||
if (any (val1 /= [1, 2, 3, 4])) stop 454
|
||||
class default
|
||||
stop 99
|
||||
end select
|
||||
print *, "PASS!"
|
||||
end subroutine
|
||||
end program select_type_openmp
|
||||
54
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90
Normal file
54
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-2.f90
Normal file
@ -0,0 +1,54 @@
|
||||
! { dg-do compile }
|
||||
! { dg-prune-output "compilation terminated." }
|
||||
!
|
||||
! FIRSTPRIVATE + class array
|
||||
!
|
||||
! For now: Expected to give "Sorry" for polymorphic arrays.
|
||||
!
|
||||
! Polymorphic arrays are tricky - at least if not allocatable, they become:
|
||||
! var.0 = var._data.data
|
||||
! which needs to be handled properly.
|
||||
!
|
||||
!
|
||||
program select_type_openmp
|
||||
!use omp_lib
|
||||
implicit none
|
||||
class(*), allocatable :: B(:)
|
||||
|
||||
allocate(B, source=["abcdef","cdefi2"])
|
||||
allocate(B, source=[1,2,3])
|
||||
call sub(B)
|
||||
contains
|
||||
subroutine sub(val2)
|
||||
class(*), allocatable :: val2(:)
|
||||
|
||||
!$OMP PARALLEL firstprivate(val2) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
|
||||
if (.not.allocated(val2)) stop 3
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 44
|
||||
if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 4545
|
||||
val2 = ["123456", "789ABC"]
|
||||
class default
|
||||
stop 991
|
||||
end select
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 44
|
||||
if (val2(1) /= "123456" .or. val2(2) /= "789ABC") stop 453
|
||||
class default
|
||||
stop 991
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (.not.allocated(val2)) stop 3
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 44
|
||||
if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 456
|
||||
class default
|
||||
stop 991
|
||||
end select
|
||||
print *, "PASS!"
|
||||
end subroutine
|
||||
end program select_type_openmp
|
||||
61
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90
Normal file
61
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90
Normal file
@ -0,0 +1,61 @@
|
||||
! { dg-do compile }
|
||||
! { dg-prune-output "compilation terminated." }
|
||||
!
|
||||
! FIRSTPRIVATE + class array
|
||||
!
|
||||
! For now: Expected to give "Sorry" for polymorphic arrays.
|
||||
!
|
||||
! Polymorphic arrays are tricky - at least if not allocatable, they become:
|
||||
! var.0 = var._data.data
|
||||
! which needs to be handled properly.
|
||||
!
|
||||
!
|
||||
program select_type_openmp
|
||||
use iso_c_binding
|
||||
!use omp_lib
|
||||
implicit none
|
||||
call sub
|
||||
contains
|
||||
subroutine sub
|
||||
integer :: i
|
||||
class(*), allocatable :: val1(:)
|
||||
type(c_ptr), allocatable :: val2(:)
|
||||
|
||||
allocate(val1, source=[1, 2, 3, 4])
|
||||
allocate(val2(2:5))
|
||||
val2 = c_null_ptr
|
||||
|
||||
!$OMP PARALLEL firstprivate(val2)
|
||||
do i = 2, 5
|
||||
if (c_associated (val2(i))) stop 123
|
||||
end do
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 33
|
||||
if (any (val1 /= [1, 2, 3, 4])) stop 4549
|
||||
val1 = [32,6,48,28]
|
||||
class default
|
||||
stop 99
|
||||
end select
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 33
|
||||
if (any (val1 /= [32,6,48,28])) stop 4512
|
||||
class default
|
||||
stop 99
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 33
|
||||
if (any (val1 /= [1, 2, 3, 4])) stop 454
|
||||
class default
|
||||
stop 99
|
||||
end select
|
||||
print *, "PASS!"
|
||||
end subroutine
|
||||
end program select_type_openmp
|
||||
44
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90
Normal file
44
gcc/testsuite/gfortran.dg/gomp/class-firstprivate-4.f90
Normal file
@ -0,0 +1,44 @@
|
||||
! { dg-do compile }
|
||||
! { dg-prune-output "compilation terminated." }
|
||||
!
|
||||
! FIRSTPRIVATE + class array
|
||||
!
|
||||
! For now: Expected to give "Sorry" for polymorphic arrays.
|
||||
!
|
||||
! Polymorphic arrays are tricky - at least if not allocatable, they become:
|
||||
! var.0 = var._data.data
|
||||
! which needs to be handled properly.
|
||||
!
|
||||
!
|
||||
program select_type_openmp
|
||||
use iso_c_binding
|
||||
!use omp_lib
|
||||
implicit none
|
||||
integer x(4)
|
||||
x = [1, 2, 3, 4]
|
||||
call sub(x)
|
||||
if (any (x /= [1,2,3,4])) stop 3
|
||||
contains
|
||||
subroutine sub(val1)
|
||||
integer :: i
|
||||
class(*) :: val1(4)
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 33
|
||||
if (any (val1 /= [1, 2, 3, 4])) stop 4549
|
||||
val1 = [32,6,48,28]
|
||||
class default
|
||||
stop 99
|
||||
end select
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (size(val1) /= 4) stop 34
|
||||
if (any (val1 /= [32,6,48,28])) stop 4512
|
||||
class default
|
||||
stop 98
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
end
|
||||
end
|
||||
323
libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90
Normal file
323
libgomp/testsuite/libgomp.fortran/class-firstprivate-1.f90
Normal file
@ -0,0 +1,323 @@
|
||||
! FIRSTPRIVATE: CLASS(*) + intrinsic types
|
||||
program select_type_openmp
|
||||
implicit none
|
||||
class(*), allocatable :: val1, val1a, val2, val3
|
||||
|
||||
call sub() ! local var
|
||||
|
||||
call sub2(val1, val1a, val2, val3) ! allocatable args
|
||||
|
||||
allocate(val1, source=7)
|
||||
allocate(val1a, source=7)
|
||||
allocate(val2, source="abcdef")
|
||||
allocate(val3, source=4_"zyx4")
|
||||
call sub3(val1, val1a, val2, val3) ! nonallocatable vars
|
||||
deallocate(val1, val1a, val2, val3)
|
||||
contains
|
||||
subroutine sub()
|
||||
class(*), allocatable :: val1, val1a, val2, val3
|
||||
allocate(val1a, source=7)
|
||||
allocate(val2, source="abcdef")
|
||||
allocate(val3, source=4_"zyx4")
|
||||
|
||||
if (allocated(val1)) stop 1
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
if (allocated(val1)) stop 2
|
||||
if (.not.allocated(val1a)) stop 3
|
||||
if (.not.allocated(val2)) stop 4
|
||||
if (.not.allocated(val3)) stop 5
|
||||
|
||||
allocate(val1, source=7)
|
||||
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (val1 /= 7) stop 6
|
||||
val1 = 8
|
||||
class default
|
||||
stop 7
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (integer)
|
||||
if (val1a /= 7) stop 8
|
||||
val1a = 8
|
||||
class default
|
||||
stop 9
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 10
|
||||
if (val2 /= "abcdef") stop 11
|
||||
val2 = "123456"
|
||||
class default
|
||||
stop 12
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 13
|
||||
if (val3 /= 4_"zyx4") stop 14
|
||||
val3 = 4_"AbCd"
|
||||
class default
|
||||
stop 15
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 16
|
||||
if (val3 /= 4_"AbCd") stop 17
|
||||
val3 = 4_"1ab2"
|
||||
class default
|
||||
stop 18
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 19
|
||||
if (val2 /= "123456") stop 20
|
||||
val2 = "A2C4E6"
|
||||
class default
|
||||
stop 21
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (val1 /= 8) stop 22
|
||||
val1 = 9
|
||||
class default
|
||||
stop 23
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (integer)
|
||||
if (val1a /= 8) stop 24
|
||||
val1a = 9
|
||||
class default
|
||||
stop 25
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (allocated(val1)) stop 26
|
||||
if (.not. allocated(val1a)) stop 27
|
||||
if (.not. allocated(val2)) stop 28
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 29
|
||||
if (val2 /= "abcdef") stop 30
|
||||
class default
|
||||
stop 31
|
||||
end select
|
||||
select type (val3)
|
||||
type is (character(len=*,kind=4))
|
||||
if (len(val3) /= 4) stop 32
|
||||
if (val3 /= 4_"zyx4") stop 33
|
||||
class default
|
||||
stop 34
|
||||
end select
|
||||
deallocate(val1a, val2, val3)
|
||||
end subroutine sub
|
||||
|
||||
subroutine sub2(val1, val1a, val2, val3)
|
||||
class(*), allocatable :: val1, val1a, val2, val3
|
||||
optional :: val1a
|
||||
allocate(val1a, source=7)
|
||||
allocate(val2, source="abcdef")
|
||||
allocate(val3, source=4_"zyx4")
|
||||
|
||||
if (allocated(val1)) stop 35
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
if (allocated(val1)) stop 36
|
||||
if (.not.allocated(val1a)) stop 37
|
||||
if (.not.allocated(val2)) stop 38
|
||||
if (.not.allocated(val3)) stop 39
|
||||
|
||||
allocate(val1, source=7)
|
||||
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (val1 /= 7) stop 40
|
||||
val1 = 8
|
||||
class default
|
||||
stop 41
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (integer)
|
||||
if (val1a /= 7) stop 42
|
||||
val1a = 8
|
||||
class default
|
||||
stop 43
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 44
|
||||
if (val2 /= "abcdef") stop 45
|
||||
val2 = "123456"
|
||||
class default
|
||||
stop 46
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 47
|
||||
if (val3 /= 4_"zyx4") stop 48
|
||||
val3 = "AbCd"
|
||||
class default
|
||||
stop 49
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 50
|
||||
if (val3 /= 4_"AbCd") stop 51
|
||||
val3 = 4_"1ab2"
|
||||
class default
|
||||
stop 52
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 53
|
||||
if (val2 /= "123456") stop 54
|
||||
val2 = "A2C4E6"
|
||||
class default
|
||||
stop 55
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (val1 /= 8) stop 56
|
||||
val1 = 9
|
||||
class default
|
||||
stop 57
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (integer)
|
||||
if (val1a /= 8) stop 58
|
||||
val1a = 9
|
||||
class default
|
||||
stop 59
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (allocated(val1)) stop 60
|
||||
if (.not. allocated(val1a)) stop 61
|
||||
if (.not. allocated(val2)) stop 62
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 63
|
||||
if (val2 /= "abcdef") stop 64
|
||||
class default
|
||||
stop 65
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 66
|
||||
if (val3 /= 4_"zyx4") stop 67
|
||||
val3 = 4_"AbCd"
|
||||
class default
|
||||
stop 68
|
||||
end select
|
||||
deallocate(val1a, val2, val3)
|
||||
end subroutine sub2
|
||||
|
||||
subroutine sub3(val1, val1a, val2, val3)
|
||||
class(*) :: val1, val1a, val2, val3
|
||||
optional :: val1a
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (val1 /= 7) stop 69
|
||||
val1 = 8
|
||||
class default
|
||||
stop 70
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (integer)
|
||||
if (val1a /= 7) stop 71
|
||||
val1a = 8
|
||||
class default
|
||||
stop 72
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 73
|
||||
if (val2 /= "abcdef") stop 74
|
||||
val2 = "123456"
|
||||
class default
|
||||
stop 75
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 76
|
||||
if (val3 /= 4_"zyx4") stop 77
|
||||
val3 = 4_"AbCd"
|
||||
class default
|
||||
stop 78
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 79
|
||||
if (val3 /= 4_"AbCd") stop 80
|
||||
val3 = 4_"1ab2"
|
||||
class default
|
||||
stop 81
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 82
|
||||
if (val2 /= "123456") stop 83
|
||||
val2 = "A2C4E6"
|
||||
class default
|
||||
stop 84
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (integer)
|
||||
if (val1 /= 8) stop 85
|
||||
val1 = 9
|
||||
class default
|
||||
stop 86
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (integer)
|
||||
if (val1a /= 8) stop 87
|
||||
val1a = 9
|
||||
class default
|
||||
stop 88
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
select type (val2)
|
||||
type is (character(len=*))
|
||||
if (len(val2) /= 6) stop 89
|
||||
if (val2 /= "abcdef") stop 90
|
||||
class default
|
||||
stop 91
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (character(len=*, kind=4))
|
||||
if (len(val3) /= 4) stop 92
|
||||
if (val3 /= 4_"zyx4") stop 93
|
||||
val3 = 4_"AbCd"
|
||||
class default
|
||||
stop 94
|
||||
end select
|
||||
end subroutine sub3
|
||||
end program select_type_openmp
|
||||
334
libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90
Normal file
334
libgomp/testsuite/libgomp.fortran/class-firstprivate-2.f90
Normal file
@ -0,0 +1,334 @@
|
||||
! FIRSTPRIVATE: CLASS(t) + derived types
|
||||
program select_type_openmp
|
||||
implicit none
|
||||
type t
|
||||
end type t
|
||||
type, extends(t) :: t_int
|
||||
integer :: i
|
||||
end type
|
||||
type, extends(t) :: t_char1
|
||||
character(len=:, kind=1), allocatable :: str
|
||||
end type
|
||||
type, extends(t) :: t_char4
|
||||
character(len=:, kind=4), allocatable :: str
|
||||
end type
|
||||
class(t), allocatable :: val1, val1a, val2, val3
|
||||
|
||||
call sub() ! local var
|
||||
|
||||
call sub2(val1, val1a, val2, val3) ! allocatable args
|
||||
|
||||
allocate(val1, source=t_int(7))
|
||||
allocate(val1a, source=t_int(7))
|
||||
allocate(val2, source=t_char1("abcdef"))
|
||||
allocate(val3, source=t_char4(4_"zyx4"))
|
||||
call sub3(val1, val1a, val2, val3) ! nonallocatable vars
|
||||
deallocate(val1, val1a, val2, val3)
|
||||
contains
|
||||
subroutine sub()
|
||||
class(t), allocatable :: val1, val1a, val2, val3
|
||||
allocate(val1a, source=t_int(7))
|
||||
allocate(val2, source=t_char1("abcdef"))
|
||||
allocate(val3, source=t_char4(4_"zyx4"))
|
||||
|
||||
if (allocated(val1)) stop 1
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
if (allocated(val1)) stop 2
|
||||
if (.not.allocated(val1a)) stop 3
|
||||
if (.not.allocated(val2)) stop 4
|
||||
if (.not.allocated(val3)) stop 5
|
||||
|
||||
allocate(val1, source=t_int(7))
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 7) stop 6
|
||||
val1%i = 8
|
||||
class default
|
||||
stop 7
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 7) stop 8
|
||||
val1a%i = 8
|
||||
class default
|
||||
stop 9
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 10
|
||||
if (val2%str /= "abcdef") stop 11
|
||||
val2%str = "123456"
|
||||
class default
|
||||
stop 12
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 13
|
||||
if (val3%str /= 4_"zyx4") stop 14
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 15
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 16
|
||||
if (val3%str /= 4_"AbCd") stop 17
|
||||
val3%str = 4_"1ab2"
|
||||
class default
|
||||
stop 18
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 19
|
||||
if (val2%str /= "123456") stop 20
|
||||
val2%str = "A2C4E6"
|
||||
class default
|
||||
stop 21
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 8) stop 22
|
||||
val1%i = 9
|
||||
class default
|
||||
stop 23
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 8) stop 24
|
||||
val1a%i = 9
|
||||
class default
|
||||
stop 25
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (allocated(val1)) stop 26
|
||||
if (.not. allocated(val1a)) stop 27
|
||||
if (.not. allocated(val2)) stop 28
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 29
|
||||
if (val2%str /= "abcdef") stop 30
|
||||
class default
|
||||
stop 31
|
||||
end select
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 32
|
||||
if (val3%str /= 4_"zyx4") stop 33
|
||||
class default
|
||||
stop 34
|
||||
end select
|
||||
deallocate(val1a,val2, val3)
|
||||
end subroutine sub
|
||||
|
||||
subroutine sub2(val1, val1a, val2, val3)
|
||||
class(t), allocatable :: val1, val1a, val2, val3
|
||||
optional :: val1a
|
||||
allocate(val1a, source=t_int(7))
|
||||
allocate(val2, source=t_char1("abcdef"))
|
||||
allocate(val3, source=t_char4(4_"zyx4"))
|
||||
|
||||
if (allocated(val1)) stop 35
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
if (allocated(val1)) stop 36
|
||||
if (.not.allocated(val1a)) stop 37
|
||||
if (.not.allocated(val2)) stop 38
|
||||
if (.not.allocated(val3)) stop 39
|
||||
|
||||
allocate(val1, source=t_int(7))
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 7) stop 40
|
||||
val1%i = 8
|
||||
class default
|
||||
stop 41
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 7) stop 42
|
||||
val1a%i = 8
|
||||
class default
|
||||
stop 43
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 44
|
||||
if (val2%str /= "abcdef") stop 45
|
||||
val2%str = "123456"
|
||||
class default
|
||||
stop 46
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 47
|
||||
if (val3%str /= 4_"zyx4") stop 48
|
||||
val3%str = "AbCd"
|
||||
class default
|
||||
stop 49
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 50
|
||||
if (val3%str /= 4_"AbCd") stop 51
|
||||
val3%str = 4_"1ab2"
|
||||
class default
|
||||
stop 52
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 53
|
||||
if (val2%str /= "123456") stop 54
|
||||
val2%str = "A2C4E6"
|
||||
class default
|
||||
stop 55
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 8) stop 56
|
||||
val1%i = 9
|
||||
class default
|
||||
stop 57
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 8) stop 58
|
||||
val1a%i = 9
|
||||
class default
|
||||
stop 59
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (allocated(val1)) stop 60
|
||||
if (.not. allocated(val1a)) stop 61
|
||||
if (.not. allocated(val2)) stop 62
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 63
|
||||
if (val2%str /= "abcdef") stop 64
|
||||
class default
|
||||
stop 65
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 66
|
||||
if (val3%str /= 4_"zyx4") stop 67
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 68
|
||||
end select
|
||||
deallocate(val1a, val2, val3)
|
||||
end subroutine sub2
|
||||
|
||||
subroutine sub3(val1, val1a, val2, val3)
|
||||
class(t) :: val1, val1a, val2, val3
|
||||
optional :: val1a
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 7) stop 69
|
||||
val1%i = 8
|
||||
class default
|
||||
stop 70
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 7) stop 71
|
||||
val1a%i = 8
|
||||
class default
|
||||
stop 72
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 73
|
||||
if (val2%str /= "abcdef") stop 74
|
||||
val2%str = "123456"
|
||||
class default
|
||||
stop 75
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 76
|
||||
if (val3%str /= 4_"zyx4") stop 77
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 78
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 79
|
||||
if (val3%str /= 4_"AbCd") stop 80
|
||||
val3%str = 4_"1ab2"
|
||||
class default
|
||||
stop 81
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 82
|
||||
if (val2%str /= "123456") stop 83
|
||||
val2%str = "A2C4E6"
|
||||
class default
|
||||
stop 84
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 8) stop 85
|
||||
val1%i = 9
|
||||
class default
|
||||
stop 86
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 8) stop 87
|
||||
val1a%i = 9
|
||||
class default
|
||||
stop 88
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 89
|
||||
if (val2%str /= "abcdef") stop 90
|
||||
class default
|
||||
stop 91
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 92
|
||||
if (val3%str /= 4_"zyx4") stop 93
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 94
|
||||
end select
|
||||
end subroutine sub3
|
||||
end program select_type_openmp
|
||||
334
libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90
Normal file
334
libgomp/testsuite/libgomp.fortran/class-firstprivate-3.f90
Normal file
@ -0,0 +1,334 @@
|
||||
! FIRSTPRIVATE: CLASS(*) + derived types
|
||||
program select_type_openmp
|
||||
implicit none
|
||||
type t
|
||||
end type t
|
||||
type, extends(t) :: t_int
|
||||
integer :: i
|
||||
end type
|
||||
type, extends(t) :: t_char1
|
||||
character(len=:, kind=1), allocatable :: str
|
||||
end type
|
||||
type, extends(t) :: t_char4
|
||||
character(len=:, kind=4), allocatable :: str
|
||||
end type
|
||||
class(*), allocatable :: val1, val1a, val2, val3
|
||||
|
||||
call sub() ! local var
|
||||
|
||||
call sub2(val1, val1a, val2, val3) ! allocatable args
|
||||
|
||||
allocate(val1, source=t_int(7))
|
||||
allocate(val1a, source=t_int(7))
|
||||
allocate(val2, source=t_char1("abcdef"))
|
||||
allocate(val3, source=t_char4(4_"zyx4"))
|
||||
call sub3(val1, val1a, val2, val3) ! nonallocatable vars
|
||||
deallocate(val1, val1a, val2, val3)
|
||||
contains
|
||||
subroutine sub()
|
||||
class(*), allocatable :: val1, val1a, val2, val3
|
||||
allocate(val1a, source=t_int(7))
|
||||
allocate(val2, source=t_char1("abcdef"))
|
||||
allocate(val3, source=t_char4(4_"zyx4"))
|
||||
|
||||
if (allocated(val1)) stop 1
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
if (allocated(val1)) stop 2
|
||||
if (.not.allocated(val1a)) stop 3
|
||||
if (.not.allocated(val2)) stop 4
|
||||
if (.not.allocated(val3)) stop 5
|
||||
|
||||
allocate(val1, source=t_int(7))
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 7) stop 6
|
||||
val1%i = 8
|
||||
class default
|
||||
stop 7
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 7) stop 8
|
||||
val1a%i = 8
|
||||
class default
|
||||
stop 9
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 10
|
||||
if (val2%str /= "abcdef") stop 11
|
||||
val2%str = "123456"
|
||||
class default
|
||||
stop 12
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 13
|
||||
if (val3%str /= 4_"zyx4") stop 14
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 15
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 16
|
||||
if (val3%str /= 4_"AbCd") stop 17
|
||||
val3%str = 4_"1ab2"
|
||||
class default
|
||||
stop 18
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 19
|
||||
if (val2%str /= "123456") stop 20
|
||||
val2%str = "A2C4E6"
|
||||
class default
|
||||
stop 21
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 8) stop 22
|
||||
val1%i = 9
|
||||
class default
|
||||
stop 23
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 8) stop 24
|
||||
val1a%i = 9
|
||||
class default
|
||||
stop 25
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (allocated(val1)) stop 26
|
||||
if (.not. allocated(val1a)) stop 27
|
||||
if (.not. allocated(val2)) stop 28
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 29
|
||||
if (val2%str /= "abcdef") stop 30
|
||||
class default
|
||||
stop 31
|
||||
end select
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 32
|
||||
if (val3%str /= 4_"zyx4") stop 33
|
||||
class default
|
||||
stop 34
|
||||
end select
|
||||
deallocate(val1a,val2, val3)
|
||||
end subroutine sub
|
||||
|
||||
subroutine sub2(val1, val1a, val2, val3)
|
||||
class(*), allocatable :: val1, val1a, val2, val3
|
||||
optional :: val1a
|
||||
allocate(val1a, source=t_int(7))
|
||||
allocate(val2, source=t_char1("abcdef"))
|
||||
allocate(val3, source=t_char4(4_"zyx4"))
|
||||
|
||||
if (allocated(val1)) stop 35
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
if (allocated(val1)) stop 36
|
||||
if (.not.allocated(val1a)) stop 37
|
||||
if (.not.allocated(val2)) stop 38
|
||||
if (.not.allocated(val3)) stop 39
|
||||
|
||||
allocate(val1, source=t_int(7))
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 7) stop 40
|
||||
val1%i = 8
|
||||
class default
|
||||
stop 41
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 7) stop 42
|
||||
val1a%i = 8
|
||||
class default
|
||||
stop 43
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 44
|
||||
if (val2%str /= "abcdef") stop 45
|
||||
val2%str = "123456"
|
||||
class default
|
||||
stop 46
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 47
|
||||
if (val3%str /= 4_"zyx4") stop 48
|
||||
val3%str = "AbCd"
|
||||
class default
|
||||
stop 49
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 50
|
||||
if (val3%str /= 4_"AbCd") stop 51
|
||||
val3%str = 4_"1ab2"
|
||||
class default
|
||||
stop 52
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 53
|
||||
if (val2%str /= "123456") stop 54
|
||||
val2%str = "A2C4E6"
|
||||
class default
|
||||
stop 55
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 8) stop 56
|
||||
val1%i = 9
|
||||
class default
|
||||
stop 57
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 8) stop 58
|
||||
val1a%i = 9
|
||||
class default
|
||||
stop 59
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (allocated(val1)) stop 60
|
||||
if (.not. allocated(val1a)) stop 61
|
||||
if (.not. allocated(val2)) stop 62
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 63
|
||||
if (val2%str /= "abcdef") stop 64
|
||||
class default
|
||||
stop 65
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 66
|
||||
if (val3%str /= 4_"zyx4") stop 67
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 68
|
||||
end select
|
||||
deallocate(val1a, val2, val3)
|
||||
end subroutine sub2
|
||||
|
||||
subroutine sub3(val1, val1a, val2, val3)
|
||||
class(*) :: val1, val1a, val2, val3
|
||||
optional :: val1a
|
||||
|
||||
!$OMP PARALLEL firstprivate(val1, val1a, val2, val3)
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 7) stop 69
|
||||
val1%i = 8
|
||||
class default
|
||||
stop 70
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 7) stop 71
|
||||
val1a%i = 8
|
||||
class default
|
||||
stop 72
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 73
|
||||
if (val2%str /= "abcdef") stop 74
|
||||
val2%str = "123456"
|
||||
class default
|
||||
stop 75
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 76
|
||||
if (val3%str /= 4_"zyx4") stop 77
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 78
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 79
|
||||
if (val3%str /= 4_"AbCd") stop 80
|
||||
val3%str = 4_"1ab2"
|
||||
class default
|
||||
stop 81
|
||||
end select
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 82
|
||||
if (val2%str /= "123456") stop 83
|
||||
val2%str = "A2C4E6"
|
||||
class default
|
||||
stop 84
|
||||
end select
|
||||
|
||||
select type (val1)
|
||||
type is (t_int)
|
||||
if (val1%i /= 8) stop 85
|
||||
val1%i = 9
|
||||
class default
|
||||
stop 86
|
||||
end select
|
||||
|
||||
select type (val1a)
|
||||
type is (t_int)
|
||||
if (val1a%i /= 8) stop 87
|
||||
val1a%i = 9
|
||||
class default
|
||||
stop 88
|
||||
end select
|
||||
!$OMP END PARALLEL
|
||||
|
||||
select type (val2)
|
||||
type is (t_char1)
|
||||
if (len(val2%str) /= 6) stop 89
|
||||
if (val2%str /= "abcdef") stop 90
|
||||
class default
|
||||
stop 91
|
||||
end select
|
||||
|
||||
select type (val3)
|
||||
type is (t_char4)
|
||||
if (len(val3%str) /= 4) stop 92
|
||||
if (val3%str /= 4_"zyx4") stop 93
|
||||
val3%str = 4_"AbCd"
|
||||
class default
|
||||
stop 94
|
||||
end select
|
||||
end subroutine sub3
|
||||
end program select_type_openmp
|
||||
Loading…
Reference in New Issue
Block a user