+2006-02-14 Jakub Jelinek <jakub@redhat.com>
+ Richard Henderson <rth@redhat.com>
+ Diego Novillo <dnovillo@redhat.com>
+
+ * invoke.texi: Document -fopenmp.
+ * gfortran.texi (Extensions): Document OpenMP.
+
+ Backport from gomp-20050608-branch
+ * trans-openmp.c: Call build_omp_clause instead of
+ make_node when creating OMP_CLAUSE_* trees.
+ (gfc_trans_omp_reduction_list): Remove argument 'code'.
+ Adjust all callers.
+
+ * trans.h (build4_v): Define.
+ * trans-openmp.c: Call build4_v to create OMP_PARALLEL nodes.
+ Call build3_v to create OMP_SECTIONS nodes.
+
+ PR fortran/25162
+ * openmp.c (gfc_match_omp_variable_list): Call gfc_set_sym_referenced
+ on all symbols added to the variable list.
+
+ * openmp.c (gfc_match_omp_clauses): Fix check for non-INTRINSIC
+ procedure symbol in REDUCTION.
+
+ * trans-openmp.c (gfc_trans_omp_array_reduction): Use gfc_add
+ for MINUS_EXPR OMP_CLAUSE_REDUCTION_CODE.
+
+ * trans-openmp.c (gfc_trans_omp_do): Add PBLOCK argument. If PBLOCK
+ is non-NULL, evaluate INIT/COND/INCR and chunk size expressions in
+ that statement block.
+ (gfc_trans_omp_parallel_do): Pass non-NULL PBLOCK to gfc_trans_omp_do
+ for non-ordered non-static combined loops.
+ (gfc_trans_omp_directive): Pass NULL PBLOCK to gfc_trans_omp_do.
+
+ * openmp.c: Include target.h and toplev.h.
+ (gfc_match_omp_threadprivate): Emit diagnostic if target does
+ not support TLS.
+ * Make-lang.in (fortran/openmp.o): Add dependencies on
+ target.h and toplev.h.
+
+ * trans-decl.c (gfc_get_fake_result_decl): Set GFC_DECL_RESULT.
+ * trans-openmp.c (gfc_omp_privatize_by_reference): Make
+ DECL_ARTIFICIAL vars predetermined shared except GFC_DECL_RESULT.
+ (gfc_omp_disregard_value_expr): Handle GFC_DECL_RESULT.
+ (gfc_trans_omp_variable): New function.
+ (gfc_trans_omp_variable_list, gfc_trans_omp_reduction_list): Use it.
+ * trans.h (GFC_DECL_RESULT): Define.
+
+ * trans-openmp.c (gfc_omp_firstprivatize_type_sizes): New function.
+ * f95-lang.c (LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES): Define.
+ * trans.h (gfc_omp_firstprivatize_type_sizes): New prototype.
+
+ * trans-openmp.c (gfc_omp_privatize_by_reference): Return
+ true if a pointer has GFC_DECL_SAVED_DESCRIPTOR set.
+ (gfc_trans_omp_array_reduction, gfc_trans_omp_reduction_list): New
+ functions.
+ (gfc_trans_omp_clauses): Add WHERE argument. Call
+ gfc_trans_omp_reduction_list rather than gfc_trans_omp_variable_list
+ for reductions.
+ (gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do,
+ gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare,
+ gfc_trans_omp_sections, gfc_trans_omp_single): Adjust
+ gfc_trans_omp_clauses callers.
+
+ * openmp.c (omp_current_do_code): New var.
+ (gfc_resolve_omp_do_blocks): New function.
+ (gfc_resolve_omp_parallel_blocks): Call it.
+ (gfc_resolve_do_iterator): Add CODE argument. Don't propagate
+ predetermination if argument is !$omp do or !$omp parallel do
+ iteration variable.
+ * resolve.c (resolve_code): Call gfc_resolve_omp_do_blocks
+ for EXEC_OMP_DO. Adjust gfc_resolve_do_iterator caller.
+ * fortran.h (gfc_resolve_omp_do_blocks): New prototype.
+ (gfc_resolve_do_iterator): Add CODE argument.
+
+ * trans.h (gfc_omp_predetermined_sharing,
+ gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New
+ prototypes.
+ (GFC_DECL_COMMON_OR_EQUIV, GFC_DECL_CRAY_POINTEE): Define.
+ * trans-openmp.c (gfc_omp_predetermined_sharing,
+ gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New
+ functions.
+ * trans-common.c (build_equiv_decl, build_common_decl,
+ create_common): Set GFC_DECL_COMMON_OR_EQUIV flag on the decls.
+ * trans-decl.c (gfc_finish_cray_pointee): Set GFC_DECL_CRAY_POINTEE
+ on the decl.
+ * f95-lang.c (LANG_HOOKS_OMP_PREDETERMINED_SHARING,
+ LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR,
+ LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE): Define.
+
+ * openmp.c (resolve_omp_clauses): Remove extraneous comma.
+
+ * symbol.c (check_conflict): Add conflict between cray_pointee and
+ threadprivate.
+ * openmp.c (gfc_match_omp_threadprivate): Fail if
+ gfc_add_threadprivate returned FAILURE.
+ (resolve_omp_clauses): Diagnose Cray pointees in SHARED,
+ {,FIRST,LAST}PRIVATE and REDUCTION clauses and Cray pointers in
+ {FIRST,LAST}PRIVATE and REDUCTION clauses.
+
+ * resolve.c (omp_workshare_flag): New variable.
+ (resolve_function): Diagnose use of non-ELEMENTAL user defined
+ function in WORKSHARE construct.
+ (resolve_code): Cleanup forall_save use. Make sure omp_workshare_flag
+ is set to correct value in different contexts.
+
+ * openmp.c (resolve_omp_clauses): Replace %s with '%s' when printing
+ variable name.
+ (resolve_omp_atomic): Likewise.
+
+ PR fortran/24493
+ * scanner.c (skip_free_comments): Set at_bol at the beginning of the
+ loop, not before it.
+ (skip_fixed_comments): Handle ! comments in the middle of line here
+ as well.
+ (gfc_skip_comments): Use skip_fixed_comments for FIXED_FORM even if
+ not at BOL.
+ (gfc_next_char_literal): Fix expected canonicalized *$omp string.
+
+ * trans-openmp.c (gfc_trans_omp_do): Use make_node and explicit
+ initialization to build OMP_FOR instead of build.
+
+ * trans-decl.c (gfc_gimplify_function): Invoke
+ diagnose_omp_structured_block_errors.
+
+ * trans-openmp.c (gfc_trans_omp_master): Use OMP_MASTER.
+ (gfc_trans_omp_ordered): Use OMP_ORDERED.
+
+ * gfortran.h (gfc_resolve_do_iterator, gfc_resolve_blocks,
+ gfc_resolve_omp_parallel_blocks): New prototypes.
+ * resolve.c (resolve_blocks): Renamed to...
+ (gfc_resolve_blocks): ... this. Remove static.
+ (gfc_resolve_forall): Adjust caller.
+ (resolve_code): Only call gfc_resolve_blocks if code->block != 0
+ and not for EXEC_OMP_PARALLEL* directives. Call
+ gfc_resolve_omp_parallel_blocks for EXEC_OMP_PARALLEL* directives.
+ Call gfc_resolve_do_iterator if resolved successfully EXEC_DO
+ iterator.
+ * openmp.c: Include pointer-set.h.
+ (omp_current_ctx): New variable.
+ (gfc_resolve_omp_parallel_blocks, gfc_resolve_do_iterator): New
+ functions.
+ * Make-lang.in (fortran/openmp.o): Depend on pointer-set.h.
+
+ * openmp.c (gfc_match_omp_clauses): For max/min/iand/ior/ieor,
+ look up symbol if it exists, use its name instead and, if it is not
+ INTRINSIC, issue diagnostics.
+
+ * parse.c (parse_omp_do): Handle implied end do properly.
+ (parse_executable): If parse_omp_do returned ST_IMPLIED_ENDDO,
+ return it instead of continuing.
+
+ * trans-openmp.c (gfc_trans_omp_critical): Update for changed
+ operand numbering.
+ (gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do,
+ gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare,
+ gfc_trans_omp_sections, gfc_trans_omp_single): Likewise.
+
+ * trans.h (gfc_omp_privatize_by_reference): New prototype.
+ * f95-lang.c (LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE): Redefine
+ to gfc_omp_privatize_by_reference.
+ * trans-openmp.c (gfc_omp_privatize_by_reference): New function.
+
+ * trans-stmt.h (gfc_trans_omp_directive): Add comment.
+
+ * openmp.c (gfc_match_omp_variable_list): Add ALLOW_COMMON argument.
+ Disallow COMMON matching if it is set.
+ (gfc_match_omp_clauses, gfc_match_omp_flush): Adjust all callers.
+ (resolve_omp_clauses): Show locus in error messages. Check that
+ variable types in reduction clauses are appropriate for reduction
+ operators.
+
+ * resolve.c (resolve_symbol): Don't error if a threadprivate module
+ variable isn't SAVEd.
+
+ * trans-openmp.c (gfc_trans_omp_do): Put count into BLOCK, not BODY.
+ Fix typo in condition. Fix DOVAR initialization.
+
+ * openmp.c (gfc_match_omp_clauses): Match min/iand/ior/ieor
+ rather than .min. etc.
+
+ * trans-openmpc.c (omp_not_yet): Remove.
+ (gfc_trans_omp_parallel_do): Keep listprivate clause on parallel.
+ Force creation of BIND_EXPR around the workshare construct.
+ (gfc_trans_omp_parallel_sections): Likewise.
+ (gfc_trans_omp_parallel_workshare): Likewise.
+
+ * types.def (BT_I16, BT_FN_I16_VPTR_I16,
+ BT_FN_BOOL_VPTR_I16_I16, BT_FN_I16_VPTR_I16_I16): Add.
+
+ * trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_DEFAULT.
+ (gfc_trans_omp_code): New function.
+ (gfc_trans_omp_do): Use it, remove omp_not_yet uses.
+ (gfc_trans_omp_parallel, gfc_trans_omp_single): Likewise.
+ (gfc_trans_omp_sections): Likewise. Only treat empty last section
+ specially if lastprivate clause is present.
+ * f95-lang.c (gfc_init_builtin_functions): Create BUILT_IN_TRAP
+ builtin.
+
+ * trans-openmp.c (gfc_trans_omp_variable_list): Update for
+ OMP_CLAUSE_DECL name change.
+ (gfc_trans_omp_do): Likewise.
+
+ * trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_REDUCTION
+ clauses.
+ (gfc_trans_omp_atomic): Build OMP_ATOMIC instead of expanding
+ sync builtins directly.
+ (gfc_trans_omp_single): Build OMP_SINGLE statement.
+
+ * trans-openmp.c (gfc_trans_add_clause): New.
+ (gfc_trans_omp_variable_list): Take a tree code and build the clause
+ node here. Link it to the head of a list.
+ (gfc_trans_omp_clauses): Update to match.
+ (gfc_trans_omp_do): Use gfc_trans_add_clause.
+
+ * trans-openmp.c (gfc_trans_omp_clauses): Change second argument to
+ gfc_omp_clauses *. Use gfc_evaluate_now instead of creating
+ temporaries by hand.
+ (gfc_trans_omp_atomic, gfc_trans_omp_critical): Use buildN_v macros.
+ (gfc_trans_omp_do): New function.
+ (gfc_trans_omp_master): Dont' check for gfc_trans_code returning NULL.
+ (gfc_trans_omp_parallel): Adjust gfc_trans_omp_clauses caller.
+ Use buildN_v macros.
+ (gfc_trans_omp_parallel_do, gfc_trans_omp_parallel_sections,
+ gfc_trans_omp_parallel_workshare, gfc_trans_omp_sections,
+ gfc_trans_omp_single, gfc_trans_omp_workshare): New functions.
+ (gfc_trans_omp_directive): Use them.
+ * parse.c (parse_omp_do): Allow new_st.op == EXEC_NOP.
+ * openmp.c (resolve_omp_clauses): Check for list items present
+ in multiple clauses.
+ (resolve_omp_do): Check that iteration variable is not THREADPRIVATE
+ and is not present in any clause variable lists other than PRIVATE
+ or LASTPRIVATE.
+
+ * gfortran.h (symbol_attribute): Add threadprivate bit.
+ (gfc_common_head): Add threadprivate member, change use_assoc
+ and saved into char to save space.
+ (gfc_add_threadprivate): New prototype.
+ * symbol.c (check_conflict): Handle threadprivate.
+ (gfc_add_threadprivate): New function.
+ (gfc_copy_attr): Copy threadprivate.
+ * trans-openmp.c (gfc_trans_omp_clauses): Avoid creating a temporary
+ if IF or NUM_THREADS is constant. Create OMP_CLAUSE_SCHEDULE and
+ OMP_CLAUSE_ORDERED.
+ * resolve.c (resolve_symbol): Complain if a THREADPRIVATE symbol
+ outside a module and not in COMMON has is not SAVEd.
+ (resolve_equivalence): Ensure THREADPRIVATE objects don't get
+ EQUIVALENCEd.
+ * trans-common.c: Include target.h and rtl.h.
+ (build_common_decl): Set DECL_TLS_MODEL if THREADPRIVATE.
+ * trans-decl.c: Include rtl.h.
+ (gfc_finish_var_decl): Set DECL_TLS_MODEL if THREADPRIVATE.
+ * dump-parse-tree.c (gfc_show_attr): Handle THREADPRIVATE.
+ * Make-lang.in (fortran/trans-decl.o): Depend on $(RTL_H).
+ (fortran/trans-common.o): Depend on $(RTL_H) and $(TARGET_H).
+ * openmp.c (gfc_match_omp_variable_list): Ensure COMMON block
+ is from current namespace.
+ (gfc_match_omp_threadprivate): Rewrite.
+ (resolve_omp_clauses): Check some clause restrictions.
+ * module.c (ab_attribute): Add AB_THREADPRIVATE.
+ (attr_bits): Add THREADPRIVATE.
+ (mio_symbol_attribute, mio_symbol_attribute): Handle threadprivate.
+ (load_commons, write_common, write_blank_common): Adjust for type
+ change of saved, store/load threadprivate bit from the integer
+ as well.
+
+ * types.def (BT_FN_UINT_UINT): New.
+ (BT_FN_VOID_UINT_UINT): Remove.
+
+ * trans-openmp.c (gfc_trans_omp_clauses, gfc_trans_omp_barrier,
+ gfc_trans_omp_critical, gfc_trans_omp_flush, gfc_trans_omp_master,
+ gfc_trans_omp_ordered, gfc_trans_omp_parallel): New functions.
+ (gfc_trans_omp_directive): Use them.
+
+ * openmp.c (expr_references_sym): Add SE argument, don't look
+ into SE tree.
+ (is_conversion): New function.
+ (resolve_omp_atomic): Adjust expr_references_sym callers. Handle
+ promoted expressions.
+ * trans-openmp.c (gfc_trans_omp_atomic): New function.
+ (gfc_trans_omp_directive): Call it.
+
+ * f95-lang.c (builtin_type_for_size): New function.
+ (gfc_init_builtin_functions): Initialize synchronization and
+ OpenMP builtins.
+ * types.def: New file.
+ * Make-lang.in (f95-lang.o): Depend on $(BUILTINS_DEF) and
+ fortran/types.def.
+
+ * trans-openmp.c: Rename GOMP_* tree codes into OMP_*.
+
+ * dump-parse-tree.c (show_symtree): Don't crash if ns->proc_name
+ is NULL.
+
+ * dump-parse-tree.c (gfc_show_namelist, gfc_show_omp_node): New
+ functions.
+ (gfc_show_code_node): Call gfc_show_omp_node for EXEC_OMP_* nodes.
+
+ * parse.c (parse_omp_do): Call pop_state before next_statement.
+ * openmp.c (expr_references_sym, resolve_omp_atomic, resolve_omp_do):
+ New functions.
+ (gfc_resolve_omp_directive): Call them.
+ * match.c (match_exit_cycle): Issue error if EXIT or CYCLE statement
+ leaves an OpenMP structured block or if EXIT terminates !$omp do
+ loop.
+
+ * Make-lang.in (F95_PARSER_OBJS): Add fortran/openmp.o.
+ (F95_OBJS): Add fortran/trans-openmp.o.
+ (fortran/trans-openmp.o): Depend on $(GFORTRAN_TRANS_DEPS).
+ * lang.opt: Add -fopenmp option.
+ * options.c (gfc_init_options): Initialize it.
+ (gfc_handle_option): Handle it.
+ * gfortran.h (ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL,
+ ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER,
+ ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO,
+ ST_OMP_END_PARALLEL_SECTIONS, ST_OMP_END_PARALLEL_WORKSHARE,
+ ST_OMP_END_SECTIONS, ST_OMP_END_SINGLE, ST_OMP_END_WORKSHARE,
+ ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED,
+ ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
+ ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION,
+ ST_OMP_SINGLE, ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE): New
+ statement codes.
+ (OMP_LIST_PRIVATE, OMP_LIST_FIRSTPRIVATE, OMP_LIST_LASTPRIVATE,
+ OMP_LIST_COPYPRIVATE, OMP_LIST_SHARED, OMP_LIST_COPYIN,
+ OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
+ OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
+ OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
+ OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST, OMP_LIST_NUM):
+ New OpenMP variable list types.
+ (gfc_omp_clauses): New typedef.
+ (gfc_get_omp_clauses): Define.
+ (EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
+ EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
+ EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
+ EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
+ EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
+ EXEC_OMP_END_SINGLE): New OpenMP gfc_exec_op codes.
+ (struct gfc_code): Add omp_clauses, omp_name, omp_namelist
+ and omp_bool fields to ext union.
+ (flag_openmp): Declare.
+ (gfc_free_omp_clauses, gfc_resolve_omp_directive): New prototypes.
+ * scanner.c (openmp_flag, openmp_locus): New variables.
+ (skip_free_comments, skip_fixed_comments, gfc_next_char_literal):
+ Handle OpenMP directive lines and conditional compilation magic
+ comments.
+ * parse.h (COMP_OMP_STRUCTURED_BLOCK): New compile state.
+ * parse.c (decode_omp_directive, parse_omp_do, parse_omp_atomic,
+ parse_omp_structured_block): New functions.
+ (next_free, next_fixed): Parse OpenMP directives.
+ (case_executable, case_exec_markers, case_decl): Add ST_OMP_*
+ codes.
+ (gfc_ascii_statement): Handle ST_OMP_* codes.
+ (parse_executable): Rearrange the loop slightly, so that
+ parse_omp_do can return next_statement.
+ * match.h (gfc_match_omp_eos, gfc_match_omp_atomic,
+ gfc_match_omp_barrier, gfc_match_omp_critical, gfc_match_omp_do,
+ gfc_match_omp_flush, gfc_match_omp_master, gfc_match_omp_ordered,
+ gfc_match_omp_parallel, gfc_match_omp_parallel_do,
+ gfc_match_omp_parallel_sections, gfc_match_omp_parallel_workshare,
+ gfc_match_omp_sections, gfc_match_omp_single,
+ gfc_match_omp_threadprivate, gfc_match_omp_workshare,
+ gfc_match_omp_end_nowait, gfc_match_omp_end_single): New prototypes.
+ * resolve.c (resolve_blocks): Ignore EXEC_OMP_* block directives.
+ (resolve_code): Call gfc_resolve_omp_directive on EXEC_OMP_*
+ directives.
+ * trans.c (gfc_trans_code): Call gfc_trans_omp_directive for
+ EXEC_OMP_* directives.
+ * st.c (gfc_free_statement): Handle EXEC_OMP_* statement freeing.
+ * trans-stmt.h (gfc_trans_omp_directive): New prototype.
+ * openmp.c: New file.
+ * trans-openmp.c: New file.
+
2006-02-13 Andrew Pinski <pinskia@physics.uc.edu>
Jakub Jelinek <jakub@redhat.com>
# -*- makefile -*-
# Top level makefile fragment for GNU gfortran, the GNU Fortran 95 compiler.
-# Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+# Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
# Contributed by Paul Brook <paul@nowt.org
# and Steven Bosscher <s.bosscher@student.tudelft.nl>
fortran/error.o fortran/expr.o fortran/interface.o \
fortran/intrinsic.o fortran/io.o fortran/iresolve.o \
fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
- fortran/options.o fortran/parse.o fortran/primary.o fortran/resolve.o \
- fortran/scanner.o fortran/simplify.o fortran/st.o fortran/symbol.o
+ fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
+ fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \
+ fortran/symbol.o
F95_OBJS = $(F95_PARSER_OBJS) \
fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
fortran/trans.o fortran/trans-array.o fortran/trans-common.o \
fortran/trans-const.o fortran/trans-decl.o fortran/trans-expr.o \
- fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-stmt.o \
- fortran/trans-types.o
+ fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-openmp.o \
+ fortran/trans-stmt.o fortran/trans-types.o
# GFORTRAN uses GMP for its internal arithmetics.
F95_LIBS = $(GMPLIBS) $(LIBS)
$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
flags.h output.h diagnostic.h errors.h function.h
+fortran/openmp.o: pointer-set.h $(TARGET_H) toplev.h
GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/intrinsic.h fortran/trans-array.h \
fortran/trans-const.h fortran/trans-const.h fortran/trans.h \
$(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h $(GGC_H)
fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
- gt-fortran-f95-lang.h gtype-fortran.h cgraph.h $(TARGET_H)
+ gt-fortran-f95-lang.h gtype-fortran.h cgraph.h $(TARGET_H) \
+ $(BUILTINS_DEF) fortran/types.def
fortran/scanner.o: toplev.h
fortran/convert.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \
- cgraph.h $(TARGET_H) function.h $(FLAGS_H) tree-gimple.h \
+ cgraph.h $(TARGET_H) function.h $(FLAGS_H) $(RTL_H) tree-gimple.h \
tree-dump.h
fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
real.h toplev.h $(TARGET_H)
fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
+fortran/trans-openmp.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h \
fortran/ioparm.def
fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
gt-fortran-trans-intrinsic.h
fortran/dependency.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
-fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS)
+fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) $(TARGET_H) $(RTL_H)
fortran/resolve.o: fortran/dependency.h
gfc_status (" POINTER");
if (attr->save)
gfc_status (" SAVE");
+ if (attr->threadprivate)
+ gfc_status (" THREADPRIVATE");
if (attr->target)
gfc_status (" TARGET");
if (attr->dummy)
gfc_show_code_node (level, c);
}
+static void
+gfc_show_namelist (gfc_namelist *n)
+{
+ for (; n->next; n = n->next)
+ gfc_status ("%s,", n->sym->name);
+ gfc_status ("%s", n->sym->name);
+}
+
+/* Show a single OpenMP directive node and everything underneath it
+ if necessary. */
+
+static void
+gfc_show_omp_node (int level, gfc_code * c)
+{
+ gfc_omp_clauses *omp_clauses = NULL;
+ const char *name = NULL;
+
+ switch (c->op)
+ {
+ case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
+ case EXEC_OMP_BARRIER: name = "BARRIER"; break;
+ case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
+ case EXEC_OMP_FLUSH: name = "FLUSH"; break;
+ case EXEC_OMP_DO: name = "DO"; break;
+ case EXEC_OMP_MASTER: name = "MASTER"; break;
+ case EXEC_OMP_ORDERED: name = "ORDERED"; break;
+ case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
+ case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
+ case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
+ case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
+ case EXEC_OMP_SINGLE: name = "SINGLE"; break;
+ case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status ("!$OMP %s", name);
+ switch (c->op)
+ {
+ case EXEC_OMP_DO:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ omp_clauses = c->ext.omp_clauses;
+ break;
+ case EXEC_OMP_CRITICAL:
+ if (c->ext.omp_name)
+ gfc_status (" (%s)", c->ext.omp_name);
+ break;
+ case EXEC_OMP_FLUSH:
+ if (c->ext.omp_namelist)
+ {
+ gfc_status (" (");
+ gfc_show_namelist (c->ext.omp_namelist);
+ gfc_status_char (')');
+ }
+ return;
+ case EXEC_OMP_BARRIER:
+ return;
+ default:
+ break;
+ }
+ if (omp_clauses)
+ {
+ int list_type;
+
+ if (omp_clauses->if_expr)
+ {
+ gfc_status (" IF(");
+ gfc_show_expr (omp_clauses->if_expr);
+ gfc_status_char (')');
+ }
+ if (omp_clauses->num_threads)
+ {
+ gfc_status (" NUM_THREADS(");
+ gfc_show_expr (omp_clauses->num_threads);
+ gfc_status_char (')');
+ }
+ if (omp_clauses->sched_kind != OMP_SCHED_NONE)
+ {
+ const char *type;
+ switch (omp_clauses->sched_kind)
+ {
+ case OMP_SCHED_STATIC: type = "STATIC"; break;
+ case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
+ case OMP_SCHED_GUIDED: type = "GUIDED"; break;
+ case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" SCHEDULE (%s", type);
+ if (omp_clauses->chunk_size)
+ {
+ gfc_status_char (',');
+ gfc_show_expr (omp_clauses->chunk_size);
+ }
+ gfc_status_char (')');
+ }
+ if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
+ {
+ const char *type;
+ switch (omp_clauses->default_sharing)
+ {
+ case OMP_DEFAULT_NONE: type = "NONE"; break;
+ case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
+ case OMP_DEFAULT_SHARED: type = "SHARED"; break;
+ case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" DEFAULT(%s)", type);
+ }
+ if (omp_clauses->ordered)
+ gfc_status (" ORDERED");
+ for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
+ if (omp_clauses->lists[list_type] != NULL
+ && list_type != OMP_LIST_COPYPRIVATE)
+ {
+ const char *type;
+ if (list_type >= OMP_LIST_REDUCTION_FIRST)
+ {
+ switch (list_type)
+ {
+ case OMP_LIST_PLUS: type = "+"; break;
+ case OMP_LIST_MULT: type = "*"; break;
+ case OMP_LIST_SUB: type = "-"; break;
+ case OMP_LIST_AND: type = ".AND."; break;
+ case OMP_LIST_OR: type = ".OR."; break;
+ case OMP_LIST_EQV: type = ".EQV."; break;
+ case OMP_LIST_NEQV: type = ".NEQV."; break;
+ case OMP_LIST_MAX: type = "MAX"; break;
+ case OMP_LIST_MIN: type = "MIN"; break;
+ case OMP_LIST_IAND: type = "IAND"; break;
+ case OMP_LIST_IOR: type = "IOR"; break;
+ case OMP_LIST_IEOR: type = "IEOR"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" REDUCTION(%s:", type);
+ }
+ else
+ {
+ switch (list_type)
+ {
+ case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
+ case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+ case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+ case OMP_LIST_SHARED: type = "SHARED"; break;
+ case OMP_LIST_COPYIN: type = "COPYIN"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" %s(", type);
+ }
+ gfc_show_namelist (omp_clauses->lists[list_type]);
+ gfc_status_char (')');
+ }
+ }
+ gfc_status_char ('\n');
+ if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
+ {
+ gfc_code *d = c->block;
+ while (d != NULL)
+ {
+ gfc_show_code (level + 1, d->next);
+ if (d->block == NULL)
+ break;
+ code_indent (level, 0);
+ gfc_status ("!$OMP SECTION\n");
+ d = d->block;
+ }
+ }
+ else
+ gfc_show_code (level + 1, c->block->next);
+ if (c->op == EXEC_OMP_ATOMIC)
+ return;
+ code_indent (level, 0);
+ gfc_status ("!$OMP END %s", name);
+ if (omp_clauses != NULL)
+ {
+ if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
+ {
+ gfc_status (" COPYPRIVATE(");
+ gfc_show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
+ gfc_status_char (')');
+ }
+ else if (omp_clauses->nowait)
+ gfc_status (" NOWAIT");
+ }
+ else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
+ gfc_status (" (%s)", c->ext.omp_name);
+}
/* Show a single code node and everything underneath it if necessary. */
gfc_status (" EOR=%d", dt->eor->value);
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_FLUSH:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ gfc_show_omp_node (level, c);
+ break;
+
default:
gfc_internal_error ("gfc_show_code_node(): Bad statement code");
}
/* gfortran backend interface
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
Contributed by Paul Brook.
This file is part of GCC.
#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
#undef LANG_HOOKS_CLEAR_BINDING_STACK
+#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
+#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
+#undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
+#undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
+#undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
/* Define lang hooks. */
#define LANG_HOOKS_NAME "GNU F95"
#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type
#define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
#define LANG_HOOKS_CLEAR_BINDING_STACK gfc_clear_binding_stack
+#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference
+#define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing
+#define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr
+#define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause
+#define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
+ gfc_omp_firstprivatize_type_sizes
const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
fntype[2] = build_function_type (type, tmp);
}
+static tree
+builtin_type_for_size (int size, bool unsignedp)
+{
+ tree type = lang_hooks.types.type_for_size (size, unsignedp);
+ return type ? type : error_mark_node;
+}
/* Initialization of builtin function nodes. */
static void
gfc_init_builtin_functions (void)
{
+ enum builtin_type
+ {
+#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
+#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
+#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
+#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
+#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
+#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
+#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
+#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
+#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
+#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
+#define DEF_POINTER_TYPE(NAME, TYPE) NAME,
+#include "types.def"
+#undef DEF_PRIMITIVE_TYPE
+#undef DEF_FUNCTION_TYPE_0
+#undef DEF_FUNCTION_TYPE_1
+#undef DEF_FUNCTION_TYPE_2
+#undef DEF_FUNCTION_TYPE_3
+#undef DEF_FUNCTION_TYPE_4
+#undef DEF_FUNCTION_TYPE_5
+#undef DEF_FUNCTION_TYPE_6
+#undef DEF_FUNCTION_TYPE_7
+#undef DEF_FUNCTION_TYPE_VAR_0
+#undef DEF_POINTER_TYPE
+ BT_LAST
+ };
+ typedef enum builtin_type builtin_type;
+ enum
+ {
+ /* So far we need just these 2 attribute types. */
+ ATTR_NOTHROW_LIST,
+ ATTR_CONST_NOTHROW_LIST
+ };
+
tree mfunc_float[3];
tree mfunc_double[3];
tree mfunc_longdouble[3];
tree func_clongdouble_longdouble;
tree ftype;
tree tmp;
+ tree builtin_types[(int) BT_LAST + 1];
build_builtin_fntypes (mfunc_float, float_type_node);
build_builtin_fntypes (mfunc_double, double_type_node);
gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
"__builtin_expect", true);
+#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
+ builtin_types[(int) ENUM] = VALUE;
+#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \
+ builtin_types[(int) ENUM] \
+ = build_function_type (builtin_types[(int) RETURN], \
+ void_list_node);
+#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \
+ builtin_types[(int) ENUM] \
+ = build_function_type (builtin_types[(int) RETURN], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG1], \
+ void_list_node));
+#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \
+ builtin_types[(int) ENUM] \
+ = build_function_type \
+ (builtin_types[(int) RETURN], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG1], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG2], \
+ void_list_node)));
+#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
+ builtin_types[(int) ENUM] \
+ = build_function_type \
+ (builtin_types[(int) RETURN], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG1], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG2], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG3], \
+ void_list_node))));
+#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
+ builtin_types[(int) ENUM] \
+ = build_function_type \
+ (builtin_types[(int) RETURN], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG1], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG2], \
+ tree_cons \
+ (NULL_TREE, \
+ builtin_types[(int) ARG3], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG4], \
+ void_list_node)))));
+#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
+ builtin_types[(int) ENUM] \
+ = build_function_type \
+ (builtin_types[(int) RETURN], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG1], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG2], \
+ tree_cons \
+ (NULL_TREE, \
+ builtin_types[(int) ARG3], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG4], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG5],\
+ void_list_node))))));
+#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+ ARG6) \
+ builtin_types[(int) ENUM] \
+ = build_function_type \
+ (builtin_types[(int) RETURN], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG1], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG2], \
+ tree_cons \
+ (NULL_TREE, \
+ builtin_types[(int) ARG3], \
+ tree_cons \
+ (NULL_TREE, \
+ builtin_types[(int) ARG4], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG5], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG6],\
+ void_list_node)))))));
+#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+ ARG6, ARG7) \
+ builtin_types[(int) ENUM] \
+ = build_function_type \
+ (builtin_types[(int) RETURN], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG1], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG2], \
+ tree_cons \
+ (NULL_TREE, \
+ builtin_types[(int) ARG3], \
+ tree_cons \
+ (NULL_TREE, \
+ builtin_types[(int) ARG4], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG5], \
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG6],\
+ tree_cons (NULL_TREE, \
+ builtin_types[(int) ARG6], \
+ void_list_node))))))));
+#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \
+ builtin_types[(int) ENUM] \
+ = build_function_type (builtin_types[(int) RETURN], NULL_TREE);
+#define DEF_POINTER_TYPE(ENUM, TYPE) \
+ builtin_types[(int) ENUM] \
+ = build_pointer_type (builtin_types[(int) TYPE]);
+#include "types.def"
+#undef DEF_PRIMITIVE_TYPE
+#undef DEF_FUNCTION_TYPE_1
+#undef DEF_FUNCTION_TYPE_2
+#undef DEF_FUNCTION_TYPE_3
+#undef DEF_FUNCTION_TYPE_4
+#undef DEF_FUNCTION_TYPE_5
+#undef DEF_FUNCTION_TYPE_6
+#undef DEF_FUNCTION_TYPE_VAR_0
+#undef DEF_POINTER_TYPE
+ builtin_types[(int) BT_LAST] = NULL_TREE;
+
+ /* Initialize synchronization builtins. */
+#undef DEF_SYNC_BUILTIN
+#define DEF_SYNC_BUILTIN(code, name, type, attr) \
+ gfc_define_builtin (name, builtin_types[type], code, name, \
+ attr == ATTR_CONST_NOTHROW_LIST);
+#include "../sync-builtins.def"
+#undef DEF_SYNC_BUILTIN
+
+ if (gfc_option.flag_openmp)
+ {
+#undef DEF_GOMP_BUILTIN
+#define DEF_GOMP_BUILTIN(code, name, type, attr) \
+ gfc_define_builtin ("__builtin_" name, builtin_types[type], \
+ code, name, attr == ATTR_CONST_NOTHROW_LIST);
+#include "../omp-builtins.def"
+#undef DEF_GOMP_BUILTIN
+ }
+
+ gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID],
+ BUILT_IN_TRAP, NULL, false);
+ TREE_THIS_VOLATILE (built_in_decls[BUILT_IN_TRAP]) = 1;
+
build_common_builtin_nodes ();
targetm.init_builtins ();
}
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE,
ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT,
- ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_NONE
+ ST_ENUM, ST_ENUMERATOR, ST_END_ENUM,
+ ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL,
+ ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL,
+ ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
+ ST_OMP_END_PARALLEL_WORKSHARE, ST_OMP_END_SECTIONS, ST_OMP_END_SINGLE,
+ ST_OMP_END_WORKSHARE, ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED,
+ ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
+ ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
+ ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE,
+ ST_NONE
}
gfc_statement;
/* Variable attributes. */
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, save:1, target:1,
- dummy:1, result:1, assign:1;
+ dummy:1, result:1, assign:1, threadprivate:1;
unsigned data:1, /* Symbol is named in a DATA statement. */
use_assoc:1; /* Symbol has been use-associated. */
#define gfc_get_namelist() gfc_getmem(sizeof(gfc_namelist))
+enum
+{
+ OMP_LIST_PRIVATE,
+ OMP_LIST_FIRSTPRIVATE,
+ OMP_LIST_LASTPRIVATE,
+ OMP_LIST_COPYPRIVATE,
+ OMP_LIST_SHARED,
+ OMP_LIST_COPYIN,
+ OMP_LIST_PLUS,
+ OMP_LIST_REDUCTION_FIRST = OMP_LIST_PLUS,
+ OMP_LIST_MULT,
+ OMP_LIST_SUB,
+ OMP_LIST_AND,
+ OMP_LIST_OR,
+ OMP_LIST_EQV,
+ OMP_LIST_NEQV,
+ OMP_LIST_MAX,
+ OMP_LIST_MIN,
+ OMP_LIST_IAND,
+ OMP_LIST_IOR,
+ OMP_LIST_IEOR,
+ OMP_LIST_REDUCTION_LAST = OMP_LIST_IEOR,
+ OMP_LIST_NUM
+};
+
+/* Because a symbol can belong to multiple namelists, they must be
+ linked externally to the symbol itself. */
+typedef struct gfc_omp_clauses
+{
+ struct gfc_expr *if_expr;
+ struct gfc_expr *num_threads;
+ gfc_namelist *lists[OMP_LIST_NUM];
+ enum
+ {
+ OMP_SCHED_NONE,
+ OMP_SCHED_STATIC,
+ OMP_SCHED_DYNAMIC,
+ OMP_SCHED_GUIDED,
+ OMP_SCHED_RUNTIME
+ } sched_kind;
+ struct gfc_expr *chunk_size;
+ enum
+ {
+ OMP_DEFAULT_UNKNOWN,
+ OMP_DEFAULT_NONE,
+ OMP_DEFAULT_PRIVATE,
+ OMP_DEFAULT_SHARED
+ } default_sharing;
+ bool nowait, ordered;
+}
+gfc_omp_clauses;
+
+#define gfc_get_omp_clauses() gfc_getmem(sizeof(gfc_omp_clauses))
+
/* The gfc_st_label structure is a doubly linked list attached to a
namespace that records the usage of statement labels within that
typedef struct gfc_common_head
{
locus where;
- int use_assoc, saved;
+ char use_assoc, saved, threadprivate;
char name[GFC_MAX_SYMBOL_LEN + 1];
struct gfc_symbol *head;
}
EXEC_ALLOCATE, EXEC_DEALLOCATE,
EXEC_OPEN, EXEC_CLOSE,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
- EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH
+ EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
+ EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
+ EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
+ EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
+ EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
+ EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
+ EXEC_OMP_END_SINGLE
}
gfc_exec_op;
struct gfc_code *whichloop;
int stop_code;
gfc_entry_list *entry;
+ gfc_omp_clauses *omp_clauses;
+ const char *omp_name;
+ gfc_namelist *omp_namelist;
+ bool omp_bool;
}
ext; /* Points to additional structures required by statement */
int flag_backslash;
int flag_cray_pointer;
int flag_d_lines;
+ int flag_openmp;
int q_kind;
try gfc_mod_pointee_as (gfc_array_spec *as);
try gfc_add_result (symbol_attribute *, const char *, locus *);
try gfc_add_save (symbol_attribute *, const char *, locus *);
+try gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
try gfc_add_saved_common (symbol_attribute *, locus *);
try gfc_add_target (symbol_attribute *, locus *);
try gfc_add_dummy (symbol_attribute *, const char *, locus *);
void gfc_free_data (gfc_data *);
void gfc_free_case_list (gfc_case *);
+/* openmp.c */
+void gfc_free_omp_clauses (gfc_omp_clauses *);
+void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
+void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *);
+void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
+
/* expr.c */
void gfc_free_actual_arglist (gfc_actual_arglist *);
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
/* resolve.c */
try gfc_resolve_expr (gfc_expr *);
void gfc_resolve (gfc_namespace *);
+void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
int gfc_impure_variable (gfc_symbol *);
int gfc_pure (gfc_symbol *);
int gfc_elemental (gfc_symbol *);
\input texinfo @c -*-texinfo-*-
@c %**start of header
@setfilename gfortran.info
-@set copyrights-gfortran 1999-2005
+@set copyrights-gfortran 1999-2006
@include gcc-common.texi
Option to initialize otherwise uninitialized integer and floating
point variables.
-@item
-Support for OpenMP directives. This also requires support from the runtime
-library and the rest of the compiler.
-
@item
Support for Fortran 200x. This includes several new features including
floating point exceptions, extended use of allocatable arrays, C
* Hollerith constants support::
* Cray pointers::
* CONVERT specifier::
+* OpenMP::
@end menu
@node Old-style kind specifications
to you, it is best if you use this only for data that needs to be
portable.
+@node OpenMP
+@section OpenMP
+@cindex OpenMP
+
+gfortran attempts to be OpenMP Application Program Interface v2.5
+compatible when invoked with the @code{-fopenmp} option. gfortran
+then generates parallellized code according to the OpenMP directives
+used in the source. The OpenMP Fortran runtime library
+routines are provided both in a form of Fortran 90 module named
+@code{omp_lib} and in a form of a Fortran @code{include} file named
+@code{omp_lib.h}.
+
+For details refer to the actual
+@uref{http://www.openmp.org/drupal/mp-documents/spec25.pdf,
+OpenMP Application Program Interface v2.5} specification.
+
@c ---------------------------------------------------------------------
@include intrinsic.texi
@c ---------------------------------------------------------------------
-@c Copyright (C) 2004, 2005
+@c Copyright (C) 2004, 2005, 2006
@c Free Software Foundation, Inc.
@c This is part of the GFORTRAN manual.
@c For copying conditions, see the file gfortran.texi.
@ignore
@c man begin COPYRIGHT
-Copyright @copyright{} 2004, 2005
+Copyright @copyright{} 2004, 2005, 2006
Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this document
-ffixed-line-length-@var{n} -ffixed-line-length-none @gol
-ffree-line-length-@var{n} -ffree-line-length-none @gol
-fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol
--fcray-pointer }
+-fcray-pointer -fopenmp }
@item Warning Options
@xref{Warning Options,,Options to Request or Suppress Warnings}.
@item -fcray-pointer
Enables the Cray pointer extension, which provides a C-like pointer.
+@cindex -fopenmp
+@cindex options, -fopenmp
+@item -fopenmp
+Enables handling of OpenMP @code{!$omp} directives in free form
+and @code{c$omp}, @code{*$omp} and @code{!$omp} directives in fixed form,
+enables @code{!$} conditional compilation sentinels in free form
+and @code{c$}, @code{*$} and @code{!$} sentinels in fixed form
+and when linking arranges for the OpenMP runtime library to be linked
+in.
+
@cindex -std=@var{std} option
@cindex option, -std=@var{std}
@item -std=@var{std}
Fortran RejectNegative
Assume that the source file is free form
+fopenmp
+Fortran
+Enable OpenMP
+
funderscoring
Fortran
Append underscores to externally visible names
static match
match_exit_cycle (gfc_statement st, gfc_exec_op op)
{
- gfc_state_data *p;
+ gfc_state_data *p, *o;
gfc_symbol *sym;
match m;
/* Find the loop mentioned specified by the label (or lack of a
label). */
- for (p = gfc_state_stack; p; p = p->previous)
+ for (o = NULL, p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
break;
+ else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
+ o = p;
if (p == NULL)
{
return MATCH_ERROR;
}
+ if (o != NULL)
+ {
+ gfc_error ("%s statement at %C leaving OpenMP structured block",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
+ else if (st == ST_EXIT
+ && p->previous != NULL
+ && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
+ && (p->previous->head->op == EXEC_OMP_DO
+ || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
+ {
+ gcc_assert (p->previous->head->next != NULL);
+ gcc_assert (p->previous->head->next->op == EXEC_DO
+ || p->previous->head->next->op == EXEC_DO_WHILE);
+ gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
+ return MATCH_ERROR;
+ }
+
/* Save the first statement in the loop - needed by the backend. */
new_st.ext.whichloop = p->head;
gfc_common_head *gfc_get_common (const char *, int);
+/* openmp.c */
+
+/* OpenMP directive matchers */
+match gfc_match_omp_eos (void);
+match gfc_match_omp_atomic (void);
+match gfc_match_omp_barrier (void);
+match gfc_match_omp_critical (void);
+match gfc_match_omp_do (void);
+match gfc_match_omp_flush (void);
+match gfc_match_omp_master (void);
+match gfc_match_omp_ordered (void);
+match gfc_match_omp_parallel (void);
+match gfc_match_omp_parallel_do (void);
+match gfc_match_omp_parallel_sections (void);
+match gfc_match_omp_parallel_workshare (void);
+match gfc_match_omp_sections (void);
+match gfc_match_omp_single (void);
+match gfc_match_omp_threadprivate (void);
+match gfc_match_omp_workshare (void);
+match gfc_match_omp_end_nowait (void);
+match gfc_match_omp_end_single (void);
+
/* decl.c */
match gfc_match_data (void);
AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
- AB_CRAY_POINTEE
+ AB_CRAY_POINTEE, AB_THREADPRIVATE
}
ab_attribute;
minit ("POINTER", AB_POINTER),
minit ("SAVE", AB_SAVE),
minit ("TARGET", AB_TARGET),
+ minit ("THREADPRIVATE", AB_THREADPRIVATE),
minit ("DUMMY", AB_DUMMY),
minit ("RESULT", AB_RESULT),
minit ("DATA", AB_DATA),
MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
if (attr->target)
MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
+ if (attr->threadprivate)
+ MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits);
if (attr->dummy)
MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
if (attr->result)
case AB_TARGET:
attr->target = 1;
break;
+ case AB_THREADPRIVATE:
+ attr->threadprivate = 1;
+ break;
case AB_DUMMY:
attr->dummy = 1;
break;
while (peek_atom () != ATOM_RPAREN)
{
+ int flags;
mio_lparen ();
mio_internal_string (name);
p = gfc_get_common (name, 1);
mio_symbol_ref (&p->head);
- mio_integer (&p->saved);
+ mio_integer (&flags);
+ if (flags & 1)
+ p->saved = 1;
+ if (flags & 2)
+ p->threadprivate = 1;
p->use_assoc = 1;
mio_rparen();
{
gfc_common_head *p;
const char * name;
+ int flags;
if (st == NULL)
return;
p = st->n.common;
mio_symbol_ref(&p->head);
- mio_integer(&p->saved);
+ flags = p->saved ? 1 : 0;
+ if (p->threadprivate) flags |= 2;
+ mio_integer(&flags);
mio_rparen();
}
write_blank_common (void)
{
const char * name = BLANK_COMMON_NAME;
+ int saved;
if (gfc_current_ns->blank_common.head == NULL)
return;
mio_pool_string(&name);
mio_symbol_ref(&gfc_current_ns->blank_common.head);
- mio_integer(&gfc_current_ns->blank_common.saved);
+ saved = gfc_current_ns->blank_common.saved;
+ mio_integer(&saved);
mio_rparen();
}
--- /dev/null
+/* OpenMP directive matching and resolving.
+ Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+ Contributed by Jakub Jelinek
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
+
+
+#include "config.h"
+#include "system.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "match.h"
+#include "parse.h"
+#include "pointer-set.h"
+#include "target.h"
+#include "toplev.h"
+
+/* Match an end of OpenMP directive. End of OpenMP directive is optional
+ whitespace, followed by '\n' or comment '!'. */
+
+match
+gfc_match_omp_eos (void)
+{
+ locus old_loc;
+ int c;
+
+ old_loc = gfc_current_locus;
+ gfc_gobble_whitespace ();
+
+ c = gfc_next_char ();
+ switch (c)
+ {
+ case '!':
+ do
+ c = gfc_next_char ();
+ while (c != '\n');
+ /* Fall through */
+
+ case '\n':
+ return MATCH_YES;
+ }
+
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+}
+
+/* Free an omp_clauses structure. */
+
+void
+gfc_free_omp_clauses (gfc_omp_clauses *c)
+{
+ int i;
+ if (c == NULL)
+ return;
+
+ gfc_free_expr (c->if_expr);
+ gfc_free_expr (c->num_threads);
+ gfc_free_expr (c->chunk_size);
+ for (i = 0; i < OMP_LIST_NUM; i++)
+ gfc_free_namelist (c->lists[i]);
+ gfc_free (c);
+}
+
+/* Match a variable/common block list and construct a namelist from it. */
+
+static match
+gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
+ bool allow_common)
+{
+ gfc_namelist *head, *tail, *p;
+ locus old_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ head = tail = NULL;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ m = gfc_match_symbol (&sym, 1);
+ switch (m)
+ {
+ case MATCH_YES:
+ gfc_set_sym_referenced (sym);
+ p = gfc_get_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->sym = sym;
+ goto next_item;
+ case MATCH_NO:
+ break;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ if (!allow_common)
+ goto syntax;
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+ for (sym = st->n.common->head; sym; sym = sym->common_next)
+ {
+ gfc_set_sym_referenced (sym);
+ p = gfc_get_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->sym = sym;
+ }
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ while (*list)
+ list = &(*list)->next;
+
+ *list = head;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in OpenMP variable list at %C");
+
+cleanup:
+ gfc_free_namelist (head);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+#define OMP_CLAUSE_PRIVATE (1 << 0)
+#define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
+#define OMP_CLAUSE_LASTPRIVATE (1 << 2)
+#define OMP_CLAUSE_COPYPRIVATE (1 << 3)
+#define OMP_CLAUSE_SHARED (1 << 4)
+#define OMP_CLAUSE_COPYIN (1 << 5)
+#define OMP_CLAUSE_REDUCTION (1 << 6)
+#define OMP_CLAUSE_IF (1 << 7)
+#define OMP_CLAUSE_NUM_THREADS (1 << 8)
+#define OMP_CLAUSE_SCHEDULE (1 << 9)
+#define OMP_CLAUSE_DEFAULT (1 << 10)
+#define OMP_CLAUSE_ORDERED (1 << 11)
+
+/* Match OpenMP directive clauses. MASK is a bitmask of
+ clauses that are allowed for a particular directive. */
+
+static match
+gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
+{
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ locus old_loc;
+ bool needs_space = true, first = true;
+
+ *cp = NULL;
+ while (1)
+ {
+ if ((first || gfc_match_char (',') != MATCH_YES)
+ && (needs_space && gfc_match_space () != MATCH_YES))
+ break;
+ needs_space = false;
+ first = false;
+ gfc_gobble_whitespace ();
+ if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
+ && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
+ && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_PRIVATE)
+ && gfc_match_omp_variable_list ("private (",
+ &c->lists[OMP_LIST_PRIVATE], true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
+ && gfc_match_omp_variable_list ("firstprivate (",
+ &c->lists[OMP_LIST_FIRSTPRIVATE],
+ true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_LASTPRIVATE)
+ && gfc_match_omp_variable_list ("lastprivate (",
+ &c->lists[OMP_LIST_LASTPRIVATE],
+ true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_COPYPRIVATE)
+ && gfc_match_omp_variable_list ("copyprivate (",
+ &c->lists[OMP_LIST_COPYPRIVATE],
+ true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_SHARED)
+ && gfc_match_omp_variable_list ("shared (",
+ &c->lists[OMP_LIST_SHARED], true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_COPYIN)
+ && gfc_match_omp_variable_list ("copyin (",
+ &c->lists[OMP_LIST_COPYIN], true)
+ == MATCH_YES)
+ continue;
+ old_loc = gfc_current_locus;
+ if ((mask & OMP_CLAUSE_REDUCTION)
+ && gfc_match ("reduction ( ") == MATCH_YES)
+ {
+ int reduction = OMP_LIST_NUM;
+ char buffer[GFC_MAX_SYMBOL_LEN + 1];
+ if (gfc_match_char ('+') == MATCH_YES)
+ reduction = OMP_LIST_PLUS;
+ else if (gfc_match_char ('*') == MATCH_YES)
+ reduction = OMP_LIST_MULT;
+ else if (gfc_match_char ('-') == MATCH_YES)
+ reduction = OMP_LIST_SUB;
+ else if (gfc_match (".and.") == MATCH_YES)
+ reduction = OMP_LIST_AND;
+ else if (gfc_match (".or.") == MATCH_YES)
+ reduction = OMP_LIST_OR;
+ else if (gfc_match (".eqv.") == MATCH_YES)
+ reduction = OMP_LIST_EQV;
+ else if (gfc_match (".neqv.") == MATCH_YES)
+ reduction = OMP_LIST_NEQV;
+ else if (gfc_match_name (buffer) == MATCH_YES)
+ {
+ gfc_symbol *sym;
+ const char *n = buffer;
+
+ gfc_find_symbol (buffer, NULL, 1, &sym);
+ if (sym != NULL)
+ {
+ if (sym->attr.intrinsic)
+ n = sym->name;
+ else if ((sym->attr.flavor != FL_UNKNOWN
+ && sym->attr.flavor != FL_PROCEDURE)
+ || sym->attr.external
+ || sym->attr.generic
+ || sym->attr.entry
+ || sym->attr.result
+ || sym->attr.dummy
+ || sym->attr.subroutine
+ || sym->attr.pointer
+ || sym->attr.target
+ || sym->attr.cray_pointer
+ || sym->attr.cray_pointee
+ || (sym->attr.proc != PROC_UNKNOWN
+ && sym->attr.proc != PROC_INTRINSIC)
+ || sym->attr.if_source != IFSRC_UNKNOWN
+ || sym == sym->ns->proc_name)
+ {
+ gfc_error_now ("%s is not INTRINSIC procedure name "
+ "at %C", buffer);
+ sym = NULL;
+ }
+ else
+ n = sym->name;
+ }
+ if (strcmp (n, "max") == 0)
+ reduction = OMP_LIST_MAX;
+ else if (strcmp (n, "min") == 0)
+ reduction = OMP_LIST_MIN;
+ else if (strcmp (n, "iand") == 0)
+ reduction = OMP_LIST_IAND;
+ else if (strcmp (n, "ior") == 0)
+ reduction = OMP_LIST_IOR;
+ else if (strcmp (n, "ieor") == 0)
+ reduction = OMP_LIST_IEOR;
+ if (reduction != OMP_LIST_NUM
+ && sym != NULL
+ && ! sym->attr.intrinsic
+ && ! sym->attr.use_assoc
+ && ((sym->attr.flavor == FL_UNKNOWN
+ && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
+ sym->name, NULL) == FAILURE)
+ || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
+ {
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+ }
+ if (reduction != OMP_LIST_NUM
+ && gfc_match_omp_variable_list (" :", &c->lists[reduction],
+ false)
+ == MATCH_YES)
+ continue;
+ else
+ gfc_current_locus = old_loc;
+ }
+ if ((mask & OMP_CLAUSE_DEFAULT)
+ && c->default_sharing == OMP_DEFAULT_UNKNOWN)
+ {
+ if (gfc_match ("default ( shared )") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_SHARED;
+ else if (gfc_match ("default ( private )") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_PRIVATE;
+ else if (gfc_match ("default ( none )") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_NONE;
+ if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
+ continue;
+ }
+ old_loc = gfc_current_locus;
+ if ((mask & OMP_CLAUSE_SCHEDULE)
+ && c->sched_kind == OMP_SCHED_NONE
+ && gfc_match ("schedule ( ") == MATCH_YES)
+ {
+ if (gfc_match ("static") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_STATIC;
+ else if (gfc_match ("dynamic") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_DYNAMIC;
+ else if (gfc_match ("guided") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_GUIDED;
+ else if (gfc_match ("runtime") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_RUNTIME;
+ if (c->sched_kind != OMP_SCHED_NONE)
+ {
+ match m = MATCH_NO;
+ if (c->sched_kind != OMP_SCHED_RUNTIME)
+ m = gfc_match (" , %e )", &c->chunk_size);
+ if (m != MATCH_YES)
+ m = gfc_match_char (')');
+ if (m != MATCH_YES)
+ c->sched_kind = OMP_SCHED_NONE;
+ }
+ if (c->sched_kind != OMP_SCHED_NONE)
+ continue;
+ else
+ gfc_current_locus = old_loc;
+ }
+ if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
+ && gfc_match ("ordered") == MATCH_YES)
+ {
+ c->ordered = needs_space = true;
+ continue;
+ }
+
+ break;
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+
+ *cp = c;
+ return MATCH_YES;
+}
+
+#define OMP_PARALLEL_CLAUSES \
+ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
+ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
+ | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
+#define OMP_DO_CLAUSES \
+ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
+ | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED)
+#define OMP_SECTIONS_CLAUSES \
+ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
+
+match
+gfc_match_omp_parallel (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_PARALLEL;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_critical (void)
+{
+ char n[GFC_MAX_SYMBOL_LEN+1];
+
+ if (gfc_match (" ( %n )", n) != MATCH_YES)
+ n[0] = '\0';
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_CRITICAL;
+ new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_do (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_DO;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_flush (void)
+{
+ gfc_namelist *list = NULL;
+ gfc_match_omp_variable_list (" (", &list, true);
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_free_namelist (list);
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_FLUSH;
+ new_st.ext.omp_namelist = list;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_threadprivate (void)
+{
+ locus old_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (" (");
+ if (m != MATCH_YES)
+ return m;
+
+ if (!targetm.have_tls)
+ {
+ sorry ("threadprivate variables not supported in this target");
+ goto cleanup;
+ }
+
+ for (;;)
+ {
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_YES:
+ if (sym->attr.in_common)
+ gfc_error_now ("Threadprivate variable at %C is an element of"
+ " a COMMON block");
+ else if (gfc_add_threadprivate (&sym->attr, sym->name,
+ &sym->declared_at) == FAILURE)
+ goto cleanup;
+ goto next_item;
+ case MATCH_NO:
+ break;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO || n[0] == '\0')
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+ st->n.common->threadprivate = 1;
+ for (sym = st->n.common->head; sym; sym = sym->common_next)
+ if (gfc_add_threadprivate (&sym->attr, sym->name,
+ &sym->declared_at) == FAILURE)
+ goto cleanup;
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
+
+cleanup:
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+match
+gfc_match_omp_parallel_do (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
+ != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_PARALLEL_DO;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_parallel_sections (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
+ != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_parallel_workshare (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_sections (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_SECTIONS;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_single (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
+ != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_SINGLE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_workshare (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_WORKSHARE;
+ new_st.ext.omp_clauses = gfc_get_omp_clauses ();
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_master (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_MASTER;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_ordered (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_ORDERED;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_atomic (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_ATOMIC;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_barrier (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_BARRIER;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_end_nowait (void)
+{
+ bool nowait = false;
+ if (gfc_match ("% nowait") == MATCH_YES)
+ nowait = true;
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_END_NOWAIT;
+ new_st.ext.omp_bool = nowait;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_end_single (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match ("% nowait") == MATCH_YES)
+ {
+ new_st.op = EXEC_OMP_END_NOWAIT;
+ new_st.ext.omp_bool = true;
+ return MATCH_YES;
+ }
+ if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_END_SINGLE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+/* OpenMP directive resolving routines. */
+
+static void
+resolve_omp_clauses (gfc_code *code)
+{
+ gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+ gfc_namelist *n;
+ int list;
+ static const char *clause_names[]
+ = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
+ "COPYIN", "REDUCTION" };
+
+ if (omp_clauses == NULL)
+ return;
+
+ if (omp_clauses->if_expr)
+ {
+ gfc_expr *expr = omp_clauses->if_expr;
+ if (gfc_resolve_expr (expr) == FAILURE
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ }
+ if (omp_clauses->num_threads)
+ {
+ gfc_expr *expr = omp_clauses->num_threads;
+ if (gfc_resolve_expr (expr) == FAILURE
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("NUM_THREADS clause at %L requires a scalar"
+ " INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->chunk_size)
+ {
+ gfc_expr *expr = omp_clauses->chunk_size;
+ if (gfc_resolve_expr (expr) == FAILURE
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("SCHEDULE clause's chunk_size at %L requires"
+ " a scalar INTEGER expression", &expr->where);
+ }
+
+ /* Check that no symbol appears on multiple clauses, except that
+ a symbol can appear on both firstprivate and lastprivate. */
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ n->sym->mark = 0;
+
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ if (n->sym->mark)
+ gfc_error ("Symbol '%s' present on multiple clauses at %L",
+ n->sym->name, &code->loc);
+ else
+ n->sym->mark = 1;
+
+ gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
+ for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ if (n->sym->mark)
+ {
+ gfc_error ("Symbol '%s' present on multiple clauses at %L",
+ n->sym->name, &code->loc);
+ n->sym->mark = 0;
+ }
+
+ for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
+ if (n->sym->mark)
+ gfc_error ("Symbol '%s' present on multiple clauses at %L",
+ n->sym->name, &code->loc);
+ else
+ n->sym->mark = 1;
+
+ for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+ n->sym->mark = 0;
+
+ for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+ if (n->sym->mark)
+ gfc_error ("Symbol '%s' present on multiple clauses at %L",
+ n->sym->name, &code->loc);
+ else
+ n->sym->mark = 1;
+
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ if ((n = omp_clauses->lists[list]) != NULL)
+ {
+ const char *name;
+
+ if (list < OMP_LIST_REDUCTION_FIRST)
+ name = clause_names[list];
+ else if (list <= OMP_LIST_REDUCTION_LAST)
+ name = clause_names[OMP_LIST_REDUCTION_FIRST];
+ else
+ gcc_unreachable ();
+
+ switch (list)
+ {
+ case OMP_LIST_COPYIN:
+ for (; n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.threadprivate)
+ gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
+ " at %L", n->sym->name, &code->loc);
+ if (n->sym->attr.allocatable)
+ gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L",
+ n->sym->name, &code->loc);
+ }
+ break;
+ case OMP_LIST_COPYPRIVATE:
+ for (; n != NULL; n = n->next)
+ {
+ if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array '%s' in COPYPRIVATE clause"
+ " at %L", n->sym->name, &code->loc);
+ if (n->sym->attr.allocatable)
+ gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE"
+ " at %L", n->sym->name, &code->loc);
+ }
+ break;
+ case OMP_LIST_SHARED:
+ for (; n != NULL; n = n->next)
+ {
+ if (n->sym->attr.threadprivate)
+ gfc_error ("THREADPRIVATE object '%s' in SHARED clause at"
+ " %L", n->sym->name, &code->loc);
+ if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee '%s' in SHARED clause at %L",
+ n->sym->name, &code->loc);
+ }
+ break;
+ default:
+ for (; n != NULL; n = n->next)
+ {
+ if (n->sym->attr.threadprivate)
+ gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
+ n->sym->name, name, &code->loc);
+ if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee '%s' in %s clause at %L",
+ n->sym->name, name, &code->loc);
+ if (list != OMP_LIST_PRIVATE)
+ {
+ if (n->sym->attr.pointer)
+ gfc_error ("POINTER object '%s' in %s clause at %L",
+ n->sym->name, name, &code->loc);
+ if (n->sym->attr.allocatable)
+ gfc_error ("%s clause object '%s' is ALLOCATABLE at %L",
+ name, n->sym->name, &code->loc);
+ if (n->sym->attr.cray_pointer)
+ gfc_error ("Cray pointer '%s' in %s clause at %L",
+ n->sym->name, name, &code->loc);
+ }
+ if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array '%s' in %s clause at %L",
+ n->sym->name, name, &code->loc);
+ if (n->sym->attr.in_namelist
+ && (list < OMP_LIST_REDUCTION_FIRST
+ || list > OMP_LIST_REDUCTION_LAST))
+ gfc_error ("Variable '%s' in %s clause is used in"
+ " NAMELIST statement at %L",
+ n->sym->name, name, &code->loc);
+ switch (list)
+ {
+ case OMP_LIST_PLUS:
+ case OMP_LIST_MULT:
+ case OMP_LIST_SUB:
+ if (!gfc_numeric_ts (&n->sym->ts))
+ gfc_error ("%c REDUCTION variable '%s' is %s at %L",
+ list == OMP_LIST_PLUS ? '+'
+ : list == OMP_LIST_MULT ? '*' : '-',
+ n->sym->name, gfc_typename (&n->sym->ts),
+ &code->loc);
+ break;
+ case OMP_LIST_AND:
+ case OMP_LIST_OR:
+ case OMP_LIST_EQV:
+ case OMP_LIST_NEQV:
+ if (n->sym->ts.type != BT_LOGICAL)
+ gfc_error ("%s REDUCTION variable '%s' must be LOGICAL"
+ " at %L",
+ list == OMP_LIST_AND ? ".AND."
+ : list == OMP_LIST_OR ? ".OR."
+ : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
+ n->sym->name, &code->loc);
+ break;
+ case OMP_LIST_MAX:
+ case OMP_LIST_MIN:
+ if (n->sym->ts.type != BT_INTEGER
+ && n->sym->ts.type != BT_REAL)
+ gfc_error ("%s REDUCTION variable '%s' must be"
+ " INTEGER or REAL at %L",
+ list == OMP_LIST_MAX ? "MAX" : "MIN",
+ n->sym->name, &code->loc);
+ break;
+ case OMP_LIST_IAND:
+ case OMP_LIST_IOR:
+ case OMP_LIST_IEOR:
+ if (n->sym->ts.type != BT_INTEGER)
+ gfc_error ("%s REDUCTION variable '%s' must be INTEGER"
+ " at %L",
+ list == OMP_LIST_IAND ? "IAND"
+ : list == OMP_LIST_MULT ? "IOR" : "IEOR",
+ n->sym->name, &code->loc);
+ break;
+ default:
+ break;
+ }
+ }
+ break;
+ }
+ }
+}
+
+/* Return true if SYM is ever referenced in EXPR except in the SE node. */
+
+static bool
+expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
+{
+ gfc_actual_arglist *arg;
+ if (e == NULL || e == se)
+ return false;
+ switch (e->expr_type)
+ {
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_VARIABLE:
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ if (e->symtree != NULL
+ && e->symtree->n.sym == s)
+ return true;
+ return false;
+ case EXPR_SUBSTRING:
+ if (e->ref != NULL
+ && (expr_references_sym (e->ref->u.ss.start, s, se)
+ || expr_references_sym (e->ref->u.ss.end, s, se)))
+ return true;
+ return false;
+ case EXPR_OP:
+ if (expr_references_sym (e->value.op.op2, s, se))
+ return true;
+ return expr_references_sym (e->value.op.op1, s, se);
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ if (expr_references_sym (arg->expr, s, se))
+ return true;
+ return false;
+ default:
+ gcc_unreachable ();
+ }
+}
+
+/* If EXPR is a conversion function that widens the type
+ if WIDENING is true or narrows the type if WIDENING is false,
+ return the inner expression, otherwise return NULL. */
+
+static gfc_expr *
+is_conversion (gfc_expr *expr, bool widening)
+{
+ gfc_typespec *ts1, *ts2;
+
+ if (expr->expr_type != EXPR_FUNCTION
+ || expr->value.function.isym == NULL
+ || expr->value.function.esym != NULL
+ || expr->value.function.isym->generic_id != GFC_ISYM_CONVERSION)
+ return NULL;
+
+ if (widening)
+ {
+ ts1 = &expr->ts;
+ ts2 = &expr->value.function.actual->expr->ts;
+ }
+ else
+ {
+ ts1 = &expr->value.function.actual->expr->ts;
+ ts2 = &expr->ts;
+ }
+
+ if (ts1->type > ts2->type
+ || (ts1->type == ts2->type && ts1->kind > ts2->kind))
+ return expr->value.function.actual->expr;
+
+ return NULL;
+}
+
+static void
+resolve_omp_atomic (gfc_code *code)
+{
+ gfc_symbol *var;
+ gfc_expr *expr2;
+
+ code = code->block->next;
+ gcc_assert (code->op == EXEC_ASSIGN);
+ gcc_assert (code->next == NULL);
+
+ if (code->expr->expr_type != EXPR_VARIABLE
+ || code->expr->symtree == NULL
+ || code->expr->rank != 0
+ || (code->expr->ts.type != BT_INTEGER
+ && code->expr->ts.type != BT_REAL
+ && code->expr->ts.type != BT_COMPLEX
+ && code->expr->ts.type != BT_LOGICAL))
+ {
+ gfc_error ("!$OMP ATOMIC statement must set a scalar variable of"
+ " intrinsic type at %L", &code->loc);
+ return;
+ }
+
+ var = code->expr->symtree->n.sym;
+ expr2 = is_conversion (code->expr2, false);
+ if (expr2 == NULL)
+ expr2 = code->expr2;
+
+ if (expr2->expr_type == EXPR_OP)
+ {
+ gfc_expr *v = NULL, *e, *c;
+ gfc_intrinsic_op op = expr2->value.op.operator;
+ gfc_intrinsic_op alt_op = INTRINSIC_NONE;
+
+ switch (op)
+ {
+ case INTRINSIC_PLUS:
+ alt_op = INTRINSIC_MINUS;
+ break;
+ case INTRINSIC_TIMES:
+ alt_op = INTRINSIC_DIVIDE;
+ break;
+ case INTRINSIC_MINUS:
+ alt_op = INTRINSIC_PLUS;
+ break;
+ case INTRINSIC_DIVIDE:
+ alt_op = INTRINSIC_TIMES;
+ break;
+ case INTRINSIC_AND:
+ case INTRINSIC_OR:
+ break;
+ case INTRINSIC_EQV:
+ alt_op = INTRINSIC_NEQV;
+ break;
+ case INTRINSIC_NEQV:
+ alt_op = INTRINSIC_EQV;
+ break;
+ default:
+ gfc_error ("!$OMP ATOMIC assignment operator must be"
+ " +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
+ &expr2->where);
+ return;
+ }
+
+ /* Check for var = var op expr resp. var = expr op var where
+ expr doesn't reference var and var op expr is mathematically
+ equivalent to var op (expr) resp. expr op var equivalent to
+ (expr) op var. We rely here on the fact that the matcher
+ for x op1 y op2 z where op1 and op2 have equal precedence
+ returns (x op1 y) op2 z. */
+ e = expr2->value.op.op2;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ v = e;
+ else if ((c = is_conversion (e, true)) != NULL
+ && c->expr_type == EXPR_VARIABLE
+ && c->symtree != NULL
+ && c->symtree->n.sym == var)
+ v = c;
+ else
+ {
+ gfc_expr **p = NULL, **q;
+ for (q = &expr2->value.op.op1; (e = *q) != NULL; )
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ {
+ v = e;
+ break;
+ }
+ else if ((c = is_conversion (e, true)) != NULL)
+ q = &e->value.function.actual->expr;
+ else if (e->expr_type != EXPR_OP
+ || (e->value.op.operator != op
+ && e->value.op.operator != alt_op)
+ || e->rank != 0)
+ break;
+ else
+ {
+ p = q;
+ q = &e->value.op.op1;
+ }
+
+ if (v == NULL)
+ {
+ gfc_error ("!$OMP ATOMIC assignment must be var = var op expr"
+ " or var = expr op var at %L", &expr2->where);
+ return;
+ }
+
+ if (p != NULL)
+ {
+ e = *p;
+ switch (e->value.op.operator)
+ {
+ case INTRINSIC_MINUS:
+ case INTRINSIC_DIVIDE:
+ case INTRINSIC_EQV:
+ case INTRINSIC_NEQV:
+ gfc_error ("!$OMP ATOMIC var = var op expr not"
+ " mathematically equivalent to var = var op"
+ " (expr) at %L", &expr2->where);
+ break;
+ default:
+ break;
+ }
+
+ /* Canonicalize into var = var op (expr). */
+ *p = e->value.op.op2;
+ e->value.op.op2 = expr2;
+ e->ts = expr2->ts;
+ if (code->expr2 == expr2)
+ code->expr2 = expr2 = e;
+ else
+ code->expr2->value.function.actual->expr = expr2 = e;
+
+ if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
+ {
+ for (p = &expr2->value.op.op1; *p != v;
+ p = &(*p)->value.function.actual->expr)
+ ;
+ *p = NULL;
+ gfc_free_expr (expr2->value.op.op1);
+ expr2->value.op.op1 = v;
+ gfc_convert_type (v, &expr2->ts, 2);
+ }
+ }
+ }
+
+ if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
+ {
+ gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr"
+ " must be scalar and cannot reference var at %L",
+ &expr2->where);
+ return;
+ }
+ }
+ else if (expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym != NULL
+ && expr2->value.function.esym == NULL
+ && expr2->value.function.actual != NULL
+ && expr2->value.function.actual->next != NULL)
+ {
+ gfc_actual_arglist *arg, *var_arg;
+
+ switch (expr2->value.function.isym->generic_id)
+ {
+ case GFC_ISYM_MIN:
+ case GFC_ISYM_MAX:
+ break;
+ case GFC_ISYM_IAND:
+ case GFC_ISYM_IOR:
+ case GFC_ISYM_IEOR:
+ if (expr2->value.function.actual->next->next != NULL)
+ {
+ gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR"
+ "or IEOR must have two arguments at %L",
+ &expr2->where);
+ return;
+ }
+ break;
+ default:
+ gfc_error ("!$OMP ATOMIC assignment intrinsic must be"
+ " MIN, MAX, IAND, IOR or IEOR at %L",
+ &expr2->where);
+ return;
+ }
+
+ var_arg = NULL;
+ for (arg = expr2->value.function.actual; arg; arg = arg->next)
+ {
+ if ((arg == expr2->value.function.actual
+ || (var_arg == NULL && arg->next == NULL))
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->symtree != NULL
+ && arg->expr->symtree->n.sym == var)
+ var_arg = arg;
+ else if (expr_references_sym (arg->expr, var, NULL))
+ gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not"
+ " reference '%s' at %L", var->name, &arg->expr->where);
+ if (arg->expr->rank != 0)
+ gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar"
+ " at %L", &arg->expr->where);
+ }
+
+ if (var_arg == NULL)
+ {
+ gfc_error ("First or last !$OMP ATOMIC intrinsic argument must"
+ " be '%s' at %L", var->name, &expr2->where);
+ return;
+ }
+
+ if (var_arg != expr2->value.function.actual)
+ {
+ /* Canonicalize, so that var comes first. */
+ gcc_assert (var_arg->next == NULL);
+ for (arg = expr2->value.function.actual;
+ arg->next != var_arg; arg = arg->next)
+ ;
+ var_arg->next = expr2->value.function.actual;
+ expr2->value.function.actual = var_arg;
+ arg->next = NULL;
+ }
+ }
+ else
+ gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic"
+ " on right hand side at %L", &expr2->where);
+}
+
+struct omp_context
+{
+ gfc_code *code;
+ struct pointer_set_t *sharing_clauses;
+ struct pointer_set_t *private_iterators;
+ struct omp_context *previous;
+} *omp_current_ctx;
+gfc_code *omp_current_do_code;
+
+void
+gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
+{
+ if (code->block->next && code->block->next->op == EXEC_DO)
+ omp_current_do_code = code->block->next;
+ gfc_resolve_blocks (code->block, ns);
+}
+
+void
+gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
+{
+ struct omp_context ctx;
+ gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+ gfc_namelist *n;
+ int list;
+
+ ctx.code = code;
+ ctx.sharing_clauses = pointer_set_create ();
+ ctx.private_iterators = pointer_set_create ();
+ ctx.previous = omp_current_ctx;
+ omp_current_ctx = &ctx;
+
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ pointer_set_insert (ctx.sharing_clauses, n->sym);
+
+ if (code->op == EXEC_OMP_PARALLEL_DO)
+ gfc_resolve_omp_do_blocks (code, ns);
+ else
+ gfc_resolve_blocks (code->block, ns);
+
+ omp_current_ctx = ctx.previous;
+ pointer_set_destroy (ctx.sharing_clauses);
+ pointer_set_destroy (ctx.private_iterators);
+}
+
+/* Note a DO iterator variable. This is special in !$omp parallel
+ construct, where they are predetermined private. */
+
+void
+gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
+{
+ struct omp_context *ctx;
+
+ if (sym->attr.threadprivate)
+ return;
+
+ /* !$omp do and !$omp parallel do iteration variable is predetermined
+ private just in the !$omp do resp. !$omp parallel do construct,
+ with no implications for the outer parallel constructs. */
+ if (code == omp_current_do_code)
+ return;
+
+ for (ctx = omp_current_ctx; ctx; ctx = ctx->previous)
+ {
+ if (pointer_set_contains (ctx->sharing_clauses, sym))
+ continue;
+
+ if (! pointer_set_insert (ctx->private_iterators, sym))
+ {
+ gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses;
+ gfc_namelist *p;
+
+ p = gfc_get_namelist ();
+ p->sym = sym;
+ p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
+ omp_clauses->lists[OMP_LIST_PRIVATE] = p;
+ }
+ }
+}
+
+static void
+resolve_omp_do (gfc_code *code)
+{
+ gfc_code *do_code;
+ int list;
+ gfc_namelist *n;
+ gfc_symbol *dovar;
+
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code);
+
+ do_code = code->block->next;
+ if (do_code->op == EXEC_DO_WHILE)
+ gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L",
+ &do_code->loc);
+ else
+ {
+ gcc_assert (do_code->op == EXEC_DO);
+ if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
+ gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
+ &do_code->loc);
+ dovar = do_code->ext.iterator->var->symtree->n.sym;
+ if (dovar->attr.threadprivate)
+ gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L",
+ &do_code->loc);
+ if (code->ext.omp_clauses)
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
+ for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
+ if (dovar == n->sym)
+ {
+ gfc_error ("!$OMP DO iteration variable present on clause"
+ " other than PRIVATE or LASTPRIVATE at %L",
+ &do_code->loc);
+ break;
+ }
+ }
+}
+
+/* Resolve OpenMP directive clauses and check various requirements
+ of each directive. */
+
+void
+gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
+{
+ switch (code->op)
+ {
+ case EXEC_OMP_DO:
+ case EXEC_OMP_PARALLEL_DO:
+ resolve_omp_do (code);
+ break;
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code);
+ break;
+ case EXEC_OMP_ATOMIC:
+ resolve_omp_atomic (code);
+ break;
+ default:
+ break;
+ }
+}
/* Parse and display command line options.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
gfc_option.flag_backslash = 1;
gfc_option.flag_cray_pointer = 0;
gfc_option.flag_d_lines = -1;
+ gfc_option.flag_openmp = 0;
gfc_option.q_kind = gfc_default_double_kind;
gfc_option.source_form = FORM_FREE;
break;
+ case OPT_fopenmp:
+ gfc_option.flag_openmp = value;
+ break;
+
case OPT_ffree_line_length_none:
gfc_option.free_line_length = 0;
break;
return ST_NONE;
}
+static gfc_statement
+decode_omp_directive (void)
+{
+ locus old_locus;
+ int c;
+
+#ifdef GFC_DEBUG
+ gfc_symbol_state ();
+#endif
+
+ gfc_clear_error (); /* Clear any pending errors. */
+ gfc_clear_warning (); /* Clear any pending warnings. */
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures");
+ gfc_error_recovery ();
+ return ST_NONE;
+ }
+
+ old_locus = gfc_current_locus;
+
+ /* General OpenMP directive matching: Instead of testing every possible
+ statement, we eliminate most possibilities by peeking at the
+ first character. */
+
+ c = gfc_peek_char ();
+
+ switch (c)
+ {
+ case 'a':
+ match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+ break;
+ case 'b':
+ match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+ break;
+ case 'c':
+ match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
+ break;
+ case 'd':
+ match ("do", gfc_match_omp_do, ST_OMP_DO);
+ break;
+ case 'e':
+ match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+ match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+ match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
+ match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+ match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
+ match ("end parallel sections", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_SECTIONS);
+ match ("end parallel workshare", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_WORKSHARE);
+ match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
+ match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
+ match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+ match ("end workshare", gfc_match_omp_end_nowait,
+ ST_OMP_END_WORKSHARE);
+ break;
+ case 'f':
+ match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
+ break;
+ case 'm':
+ match ("master", gfc_match_omp_master, ST_OMP_MASTER);
+ break;
+ case 'o':
+ match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
+ break;
+ case 'p':
+ match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
+ match ("parallel sections", gfc_match_omp_parallel_sections,
+ ST_OMP_PARALLEL_SECTIONS);
+ match ("parallel workshare", gfc_match_omp_parallel_workshare,
+ ST_OMP_PARALLEL_WORKSHARE);
+ match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
+ break;
+ case 's':
+ match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
+ match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+ match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
+ break;
+ case 't':
+ match ("threadprivate", gfc_match_omp_threadprivate,
+ ST_OMP_THREADPRIVATE);
+ case 'w':
+ match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
+ break;
+ }
+
+ /* All else has failed, so give up. See if any of the matchers has
+ stored an error message of some sort. */
+
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable OpenMP directive at %C");
+
+ reject_statement ();
+
+ gfc_error_recovery ();
+
+ return ST_NONE;
+}
+
#undef match
}
}
}
+ else if (c == '!')
+ {
+ /* Comments have already been skipped by the time we get here,
+ except for OpenMP directives. */
+ if (gfc_option.flag_openmp)
+ {
+ int i;
+
+ c = gfc_next_char ();
+ for (i = 0; i < 5; i++, c = gfc_next_char ())
+ gcc_assert (c == "!$omp"[i]);
+
+ gcc_assert (c == ' ');
+ return decode_omp_directive ();
+ }
+ }
return decode_statement ();
}
digit_flag = 1;
break;
- /* Comments have already been skipped by the time we get
+ /* Comments have already been skipped by the time we get
+ here, except for OpenMP directives. */
+ case '*':
+ if (gfc_option.flag_openmp)
+ {
+ for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
+ gcc_assert (TOLOWER (c) == "*$omp"[i]);
+
+ if (c != ' ' && c != '0')
+ {
+ gfc_buffer_error (0);
+ gfc_error ("Bad continuation line at %C");
+ return ST_NONE;
+ }
+
+ return decode_omp_directive ();
+ }
+ /* FALLTHROUGH */
+
+ /* Comments have already been skipped by the time we get
here so don't bother checking for them. */
default:
case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
- case ST_LABEL_ASSIGNMENT: case ST_FLUSH
+ case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
+ case ST_OMP_BARRIER
/* Statements that mark other executable statements. */
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
- case ST_WHERE_BLOCK: case ST_SELECT_CASE
+ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
+ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
+ case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
+ case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
+ case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
/* Declaration statements */
#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
- case ST_TYPE: case ST_INTERFACE
+ case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
case ST_END_ENUM:
p = "END ENUM";
break;
+ case ST_OMP_ATOMIC:
+ p = "!$OMP ATOMIC";
+ break;
+ case ST_OMP_BARRIER:
+ p = "!$OMP BARRIER";
+ break;
+ case ST_OMP_CRITICAL:
+ p = "!$OMP CRITICAL";
+ break;
+ case ST_OMP_DO:
+ p = "!$OMP DO";
+ break;
+ case ST_OMP_END_CRITICAL:
+ p = "!$OMP END CRITICAL";
+ break;
+ case ST_OMP_END_DO:
+ p = "!$OMP END DO";
+ break;
+ case ST_OMP_END_MASTER:
+ p = "!$OMP END MASTER";
+ break;
+ case ST_OMP_END_ORDERED:
+ p = "!$OMP END ORDERED";
+ break;
+ case ST_OMP_END_PARALLEL:
+ p = "!$OMP END PARALLEL";
+ break;
+ case ST_OMP_END_PARALLEL_DO:
+ p = "!$OMP END PARALLEL DO";
+ break;
+ case ST_OMP_END_PARALLEL_SECTIONS:
+ p = "!$OMP END PARALLEL SECTIONS";
+ break;
+ case ST_OMP_END_PARALLEL_WORKSHARE:
+ p = "!$OMP END PARALLEL WORKSHARE";
+ break;
+ case ST_OMP_END_SECTIONS:
+ p = "!$OMP END SECTIONS";
+ break;
+ case ST_OMP_END_SINGLE:
+ p = "!$OMP END SINGLE";
+ break;
+ case ST_OMP_END_WORKSHARE:
+ p = "!$OMP END WORKSHARE";
+ break;
+ case ST_OMP_FLUSH:
+ p = "!$OMP FLUSH";
+ break;
+ case ST_OMP_MASTER:
+ p = "!$OMP MASTER";
+ break;
+ case ST_OMP_ORDERED:
+ p = "!$OMP ORDERED";
+ break;
+ case ST_OMP_PARALLEL:
+ p = "!$OMP PARALLEL";
+ break;
+ case ST_OMP_PARALLEL_DO:
+ p = "!$OMP PARALLEL DO";
+ break;
+ case ST_OMP_PARALLEL_SECTIONS:
+ p = "!$OMP PARALLEL SECTIONS";
+ break;
+ case ST_OMP_PARALLEL_WORKSHARE:
+ p = "!$OMP PARALLEL WORKSHARE";
+ break;
+ case ST_OMP_SECTIONS:
+ p = "!$OMP SECTIONS";
+ break;
+ case ST_OMP_SECTION:
+ p = "!$OMP SECTION";
+ break;
+ case ST_OMP_SINGLE:
+ p = "!$OMP SINGLE";
+ break;
+ case ST_OMP_THREADPRIVATE:
+ p = "!$OMP THREADPRIVATE";
+ break;
+ case ST_OMP_WORKSHARE:
+ p = "!$OMP WORKSHARE";
+ break;
default:
gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
}
}
+/* Parse the statements of OpenMP do/parallel do. */
+
+static gfc_statement
+parse_omp_do (gfc_statement omp_st)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (omp_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ for (;;)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_DO)
+ break;
+ else
+ unexpected_statement (st);
+ }
+
+ parse_do_block ();
+ if (gfc_statement_label != NULL
+ && gfc_state_stack->previous != NULL
+ && gfc_state_stack->previous->state == COMP_DO
+ && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
+ {
+ /* In
+ DO 100 I=1,10
+ !$OMP DO
+ DO J=1,10
+ ...
+ 100 CONTINUE
+ there should be no !$OMP END DO. */
+ pop_state ();
+ return ST_IMPLIED_ENDDO;
+ }
+
+ check_do_closure ();
+ pop_state ();
+
+ st = next_statement ();
+ if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
+ {
+ if (new_st.op == EXEC_OMP_END_NOWAIT)
+ cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+ else
+ gcc_assert (new_st.op == EXEC_NOP);
+ gfc_clear_new_st ();
+ st = next_statement ();
+ }
+ return st;
+}
+
+
+/* Parse the statements of OpenMP atomic directive. */
+
+static void
+parse_omp_atomic (void)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (ST_OMP_ATOMIC);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ for (;;)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_ASSIGNMENT)
+ break;
+ else
+ unexpected_statement (st);
+ }
+
+ accept_statement (st);
+
+ pop_state ();
+}
+
+
+/* Parse the statements of an OpenMP structured block. */
+
+static void
+parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
+{
+ gfc_statement st, omp_end_st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (omp_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ switch (omp_st)
+ {
+ case ST_OMP_PARALLEL:
+ omp_end_st = ST_OMP_END_PARALLEL;
+ break;
+ case ST_OMP_PARALLEL_SECTIONS:
+ omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
+ break;
+ case ST_OMP_SECTIONS:
+ omp_end_st = ST_OMP_END_SECTIONS;
+ break;
+ case ST_OMP_ORDERED:
+ omp_end_st = ST_OMP_END_ORDERED;
+ break;
+ case ST_OMP_CRITICAL:
+ omp_end_st = ST_OMP_END_CRITICAL;
+ break;
+ case ST_OMP_MASTER:
+ omp_end_st = ST_OMP_END_MASTER;
+ break;
+ case ST_OMP_SINGLE:
+ omp_end_st = ST_OMP_END_SINGLE;
+ break;
+ case ST_OMP_WORKSHARE:
+ omp_end_st = ST_OMP_END_WORKSHARE;
+ break;
+ case ST_OMP_PARALLEL_WORKSHARE:
+ omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ do
+ {
+ if (workshare_stmts_only)
+ {
+ /* Inside of !$omp workshare, only
+ scalar assignments
+ array assignments
+ where statements and constructs
+ forall statements and constructs
+ !$omp atomic
+ !$omp critical
+ !$omp parallel
+ are allowed. For !$omp critical these
+ restrictions apply recursively. */
+ bool cycle = true;
+
+ st = next_statement ();
+ for (;;)
+ {
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+
+ case ST_ASSIGNMENT:
+ case ST_WHERE:
+ case ST_FORALL:
+ accept_statement (st);
+ break;
+
+ case ST_WHERE_BLOCK:
+ parse_where_block ();
+ break;
+
+ case ST_FORALL_BLOCK:
+ parse_forall_block ();
+ break;
+
+ case ST_OMP_PARALLEL:
+ case ST_OMP_PARALLEL_SECTIONS:
+ parse_omp_structured_block (st, false);
+ break;
+
+ case ST_OMP_PARALLEL_WORKSHARE:
+ case ST_OMP_CRITICAL:
+ parse_omp_structured_block (st, true);
+ break;
+
+ case ST_OMP_PARALLEL_DO:
+ st = parse_omp_do (st);
+ continue;
+
+ case ST_OMP_ATOMIC:
+ parse_omp_atomic ();
+ break;
+
+ default:
+ cycle = false;
+ break;
+ }
+
+ if (!cycle)
+ break;
+
+ st = next_statement ();
+ }
+ }
+ else
+ st = parse_executable (ST_NONE);
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_OMP_SECTION
+ && (omp_st == ST_OMP_SECTIONS
+ || omp_st == ST_OMP_PARALLEL_SECTIONS))
+ {
+ np = new_level (np);
+ np->op = cp->op;
+ np->block = NULL;
+ }
+ else if (st != omp_end_st)
+ unexpected_statement (st);
+ }
+ while (st != omp_end_st);
+
+ switch (new_st.op)
+ {
+ case EXEC_OMP_END_NOWAIT:
+ cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+ break;
+ case EXEC_OMP_CRITICAL:
+ if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
+ || (new_st.ext.omp_name != NULL
+ && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
+ gfc_error ("Name after !$omp critical and !$omp end critical does"
+ " not match at %C");
+ gfc_free ((char *) new_st.ext.omp_name);
+ break;
+ case EXEC_OMP_END_SINGLE:
+ cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
+ = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
+ new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
+ gfc_free_omp_clauses (new_st.ext.omp_clauses);
+ break;
+ case EXEC_NOP:
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ gfc_clear_new_st ();
+ pop_state ();
+}
+
+
/* Accept a series of executable statements. We return the first
statement that doesn't fit to the caller. Any block statements are
passed on to the correct handler, which usually passes the buck
if (st == ST_NONE)
st = next_statement ();
- for (;; st = next_statement ())
+ for (;;)
{
-
close_flag = check_do_closure ();
if (close_flag)
switch (st)
accept_statement (st);
if (close_flag == 1)
return ST_IMPLIED_ENDDO;
- continue;
+ break;
case ST_IF_BLOCK:
parse_if_block ();
- continue;
+ break;
case ST_SELECT_CASE:
parse_select_block ();
- continue;
+ break;
case ST_DO:
parse_do_block ();
if (check_do_closure () == 1)
return ST_IMPLIED_ENDDO;
- continue;
+ break;
case ST_WHERE_BLOCK:
parse_where_block ();
- continue;
+ break;
case ST_FORALL_BLOCK:
parse_forall_block ();
+ break;
+
+ case ST_OMP_PARALLEL:
+ case ST_OMP_PARALLEL_SECTIONS:
+ case ST_OMP_SECTIONS:
+ case ST_OMP_ORDERED:
+ case ST_OMP_CRITICAL:
+ case ST_OMP_MASTER:
+ case ST_OMP_SINGLE:
+ parse_omp_structured_block (st, false);
+ break;
+
+ case ST_OMP_WORKSHARE:
+ case ST_OMP_PARALLEL_WORKSHARE:
+ parse_omp_structured_block (st, true);
+ break;
+
+ case ST_OMP_DO:
+ case ST_OMP_PARALLEL_DO:
+ st = parse_omp_do (st);
+ if (st == ST_IMPLIED_ENDDO)
+ return st;
continue;
- default:
+ case ST_OMP_ATOMIC:
+ parse_omp_atomic ();
break;
+
+ default:
+ return st;
}
- break;
+ st = next_statement ();
}
-
- return st;
}
/* Parser header
- Copyright (C) 2003 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc.
Contributed by Steven Bosscher
This file is part of GCC.
{
COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_IF, COMP_DO,
- COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM
+ COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
+ COMP_OMP_STRUCTURED_BLOCK
}
gfc_compile_state;
static code_stack *cs_base = NULL;
-/* Nonzero if we're inside a FORALL block */
+/* Nonzero if we're inside a FORALL block. */
static int forall_flag;
+/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
+
+static int omp_workshare_flag;
+
/* Nonzero if we are processing a formal arglist. The corresponding function
resets the flag each time that it is read. */
static int formal_arg_flag = 0;
return FAILURE;
}
}
+ if (omp_workshare_flag
+ && expr->value.function.esym
+ && ! gfc_elemental (expr->value.function.esym))
+ {
+ gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
+ " in WORKSHARE construct", expr->value.function.esym->name,
+ &expr->where);
+ t = FAILURE;
+ }
else if (expr->value.function.actual != NULL
&& expr->value.function.isym != NULL
gfc_resolve_assign_in_forall (c, nvar, var_expr);
break;
- /* Because the resolve_blocks() will handle the nested FORALL,
+ /* Because the gfc_resolve_blocks() will handle the nested FORALL,
there is no need to handle it here. */
case EXEC_FORALL:
break;
/* Given a FORALL construct, first resolve the FORALL iterator, then call
gfc_resolve_forall_body to resolve the FORALL body. */
-static void resolve_blocks (gfc_code *, gfc_namespace *);
-
static void
gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
{
gfc_resolve_forall_body (code, nvar, var_expr);
/* May call gfc_resolve_forall to resolve the inner FORALL loop. */
- resolve_blocks (code->block, ns);
+ gfc_resolve_blocks (code->block, ns);
/* Free VAR_EXPR after the whole FORALL construct resolved. */
for (i = 0; i < total_var; i++)
static void resolve_code (gfc_code *, gfc_namespace *);
-static void
-resolve_blocks (gfc_code * b, gfc_namespace * ns)
+void
+gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
{
try t;
case EXEC_IOLENGTH:
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ break;
+
default:
gfc_internal_error ("resolve_block(): Bad block type");
}
static void
resolve_code (gfc_code * code, gfc_namespace * ns)
{
- int forall_save = 0;
+ int omp_workshare_save;
code_stack frame;
gfc_alloc *a;
try t;
if (code->op == EXEC_FORALL)
{
- forall_save = forall_flag;
+ int forall_save = forall_flag;
+
forall_flag = 1;
- gfc_resolve_forall (code, ns, forall_save);
- }
- else
- resolve_blocks (code->block, ns);
+ gfc_resolve_forall (code, ns, forall_save);
+ forall_flag = forall_save;
+ }
+ else if (code->block)
+ {
+ omp_workshare_save = -1;
+ switch (code->op)
+ {
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 1;
+ gfc_resolve_omp_parallel_blocks (code, ns);
+ break;
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 0;
+ gfc_resolve_omp_parallel_blocks (code, ns);
+ break;
+ case EXEC_OMP_DO:
+ gfc_resolve_omp_do_blocks (code, ns);
+ break;
+ case EXEC_OMP_WORKSHARE:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 1;
+ /* FALLTHROUGH */
+ default:
+ gfc_resolve_blocks (code->block, ns);
+ break;
+ }
- if (code->op == EXEC_FORALL)
- forall_flag = forall_save;
+ if (omp_workshare_save != -1)
+ omp_workshare_flag = omp_workshare_save;
+ }
t = gfc_resolve_expr (code->expr);
if (gfc_resolve_expr (code->expr2) == FAILURE)
case EXEC_DO:
if (code->ext.iterator != NULL)
- gfc_resolve_iterator (code->ext.iterator, true);
+ {
+ gfc_iterator *iter = code->ext.iterator;
+ if (gfc_resolve_iterator (iter, true) != FAILURE)
+ gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
+ }
break;
case EXEC_DO_WHILE:
&code->expr->where);
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_FLUSH:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ gfc_resolve_omp_directive (code, ns);
+ break;
+
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 0;
+ gfc_resolve_omp_directive (code, ns);
+ omp_workshare_flag = omp_workshare_save;
+ break;
+
default:
gfc_internal_error ("resolve_code(): Bad statement code");
}
gfc_resolve (sym->formal_ns);
formal_ns_flag = formal_ns_save;
}
+
+ /* Check threadprivate restrictions. */
+ if (sym->attr.threadprivate && !sym->attr.save
+ && (!sym->attr.in_common
+ && sym->module == NULL
+ && (sym->ns->proc_name == NULL
+ || sym->ns->proc_name->attr.flavor != FL_MODULE)))
+ gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
}
/* Character scanner.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
Free Software Foundation, Inc.
Contributed by Andy Vaught
static gfc_file *file_head, *current_file;
-static int continue_flag, end_flag;
+static int continue_flag, end_flag, openmp_flag;
+static locus openmp_locus;
gfc_source_form gfc_current_form;
static gfc_linebuf *line_head, *line_tail;
{
locus start;
char c;
+ int at_bol;
for (;;)
{
+ at_bol = gfc_at_bol ();
start = gfc_current_locus;
if (gfc_at_eof ())
break;
do
- {
- c = next_char ();
- }
+ c = next_char ();
while (gfc_is_whitespace (c));
if (c == '\n')
if (c == '!')
{
+ /* If -fopenmp, we need to handle here 2 things:
+ 1) don't treat !$omp as comments, but directives
+ 2) handle OpenMP conditional compilation, where
+ !$ should be treated as 2 spaces (for initial lines
+ only if followed by space). */
+ if (gfc_option.flag_openmp && at_bol)
+ {
+ locus old_loc = gfc_current_locus;
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'o' || c == 'O')
+ {
+ if (((c = next_char ()) == 'm' || c == 'M')
+ && ((c = next_char ()) == 'p' || c == 'P')
+ && ((c = next_char ()) == ' ' || continue_flag))
+ {
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ if (c != '\n' && c != '!')
+ {
+ openmp_flag = 1;
+ openmp_locus = old_loc;
+ gfc_current_locus = start;
+ return;
+ }
+ }
+ gfc_current_locus = old_loc;
+ next_char ();
+ c = next_char ();
+ }
+ if (continue_flag || c == ' ')
+ {
+ gfc_current_locus = old_loc;
+ next_char ();
+ return;
+ }
+ }
+ gfc_current_locus = old_loc;
+ }
skip_comment_line ();
continue;
}
break;
}
+ if (openmp_flag && at_bol)
+ openmp_flag = 0;
gfc_current_locus = start;
}
int col;
char c;
+ if (! gfc_at_bol ())
+ {
+ start = gfc_current_locus;
+ if (! gfc_at_eof ())
+ {
+ do
+ c = next_char ();
+ while (gfc_is_whitespace (c));
+
+ if (c == '\n')
+ gfc_advance_line ();
+ else if (c == '!')
+ skip_comment_line ();
+ }
+
+ if (! gfc_at_bol ())
+ {
+ gfc_current_locus = start;
+ return;
+ }
+ }
+
for (;;)
{
start = gfc_current_locus;
if (c == '!' || c == 'c' || c == 'C' || c == '*')
{
+ /* If -fopenmp, we need to handle here 2 things:
+ 1) don't treat !$omp|c$omp|*$omp as comments, but directives
+ 2) handle OpenMP conditional compilation, where
+ !$|c$|*$ should be treated as 2 spaces if the characters
+ in columns 3 to 6 are valid fixed form label columns
+ characters. */
+ if (gfc_option.flag_openmp)
+ {
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'o' || c == 'O')
+ {
+ if (((c = next_char ()) == 'm' || c == 'M')
+ && ((c = next_char ()) == 'p' || c == 'P'))
+ {
+ c = next_char ();
+ if (c != '\n'
+ && ((openmp_flag && continue_flag)
+ || c == ' ' || c == '0'))
+ {
+ c = next_char ();
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ if (c != '\n' && c != '!')
+ {
+ /* Canonicalize to *$omp. */
+ *start.nextc = '*';
+ openmp_flag = 1;
+ gfc_current_locus = start;
+ return;
+ }
+ }
+ }
+ }
+ else
+ {
+ int digit_seen = 0;
+
+ for (col = 3; col < 6; col++, c = next_char ())
+ if (c == ' ')
+ continue;
+ else if (c < '0' || c > '9')
+ break;
+ else
+ digit_seen = 1;
+
+ if (col == 6 && c != '\n'
+ && ((continue_flag && !digit_seen)
+ || c == ' ' || c == '0'))
+ {
+ gfc_current_locus = start;
+ start.nextc[0] = ' ';
+ start.nextc[1] = ' ';
+ continue;
+ }
+ }
+ }
+ gfc_current_locus = start;
+ }
skip_comment_line ();
continue;
}
break;
}
+ openmp_flag = 0;
gfc_current_locus = start;
}
-/* Skips the current line if it is a comment. Assumes that we are at
- the start of the current line. */
+/* Skips the current line if it is a comment. */
void
gfc_skip_comments (void)
{
-
- if (!gfc_at_bol () || gfc_current_form == FORM_FREE)
+ if (gfc_current_form == FORM_FREE)
skip_free_comments ();
else
skip_fixed_comments ();
gfc_next_char_literal (int in_string)
{
locus old_loc;
- int i, c;
+ int i, c, prev_openmp_flag;
continue_flag = 0;
if (gfc_current_form == FORM_FREE)
{
-
if (!in_string && c == '!')
{
+ if (openmp_flag
+ && memcmp (&gfc_current_locus, &openmp_locus,
+ sizeof (gfc_current_locus)) == 0)
+ goto done;
+
/* This line can't be continued */
do
{
goto done;
/* If the next nonblank character is a ! or \n, we've got a
- continuation line. */
+ continuation line. */
old_loc = gfc_current_locus;
c = next_char ();
c = next_char ();
/* Character constants to be continued cannot have commentary
- after the '&'. */
+ after the '&'. */
if (in_string && c != '\n')
{
goto done;
}
+ prev_openmp_flag = openmp_flag;
continue_flag = 1;
if (c == '!')
skip_comment_line ();
gfc_advance_line ();
/* We've got a continuation line and need to find where it continues.
- First eat any comment lines. */
+ First eat any comment lines. */
gfc_skip_comments ();
+ if (prev_openmp_flag != openmp_flag)
+ {
+ gfc_current_locus = old_loc;
+ openmp_flag = prev_openmp_flag;
+ c = '&';
+ goto done;
+ }
+
/* Now that we have a non-comment line, probe ahead for the
- first non-whitespace character. If it is another '&', then
- reading starts at the next character, otherwise we must back
- up to where the whitespace started and resume from there. */
+ first non-whitespace character. If it is another '&', then
+ reading starts at the next character, otherwise we must back
+ up to where the whitespace started and resume from there. */
old_loc = gfc_current_locus;
while (gfc_is_whitespace (c))
c = next_char ();
+ if (openmp_flag)
+ {
+ for (i = 0; i < 5; i++, c = next_char ())
+ {
+ gcc_assert (TOLOWER (c) == "!$omp"[i]);
+ if (i == 4)
+ old_loc = gfc_current_locus;
+ }
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ }
+
if (c != '&')
gfc_current_locus = old_loc;
-
}
else
{
if (c != '\n')
goto done;
+ prev_openmp_flag = openmp_flag;
continue_flag = 1;
old_loc = gfc_current_locus;
gfc_skip_comments ();
/* See if this line is a continuation line. */
- for (i = 0; i < 5; i++)
+ if (openmp_flag != prev_openmp_flag)
{
- c = next_char ();
- if (c != ' ')
- goto not_continuation;
+ openmp_flag = prev_openmp_flag;
+ goto not_continuation;
}
+ if (!openmp_flag)
+ for (i = 0; i < 5; i++)
+ {
+ c = next_char ();
+ if (c != ' ')
+ goto not_continuation;
+ }
+ else
+ for (i = 0; i < 5; i++)
+ {
+ c = next_char ();
+ if (TOLOWER (c) != "*$omp"[i])
+ goto not_continuation;
+ }
+
c = next_char ();
- if (c == '0' || c == ' ')
+ if (c == '0' || c == ' ' || c == '\n')
goto not_continuation;
}
/* Build executable statement trees.
- Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
gfc_free_forall_iterator (p->ext.forall_iterator);
break;
+ case EXEC_OMP_DO:
+ case EXEC_OMP_END_SINGLE:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ gfc_free_omp_clauses (p->ext.omp_clauses);
+ break;
+
+ case EXEC_OMP_CRITICAL:
+ gfc_free ((char *) p->ext.omp_name);
+ break;
+
+ case EXEC_OMP_FLUSH:
+ gfc_free_namelist (p->ext.omp_namelist);
+ break;
+
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_END_NOWAIT:
+ break;
+
default:
gfc_internal_error ("gfc_free_statement(): Bad statement");
}
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA";
+ static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
}
conf (dummy, save);
+ conf (dummy, threadprivate);
conf (pointer, target);
conf (pointer, external);
conf (pointer, intrinsic);
conf (in_equivalence, result);
conf (in_equivalence, entry);
conf (in_equivalence, allocatable);
+ conf (in_equivalence, threadprivate);
conf (in_namelist, pointer);
conf (in_namelist, allocatable);
conf (cray_pointee, entry);
conf (cray_pointee, in_common);
conf (cray_pointee, in_equivalence);
+ conf (cray_pointee, threadprivate);
conf (data, dummy);
conf (data, function);
conf2 (optional);
conf2 (function);
conf2 (subroutine);
+ conf2 (threadprivate);
break;
case FL_VARIABLE:
conf2(result);
conf2(in_namelist);
conf2(function);
+ conf2(threadprivate);
}
switch (attr->proc)
conf2 (result);
conf2 (in_common);
conf2 (save);
+ conf2 (threadprivate);
break;
default:
conf2 (entry);
conf2 (function);
conf2 (subroutine);
+ conf2 (threadprivate);
if (attr->intent != INTENT_UNKNOWN)
{
conf2 (dummy);
conf2 (in_common);
conf2 (save);
+ conf2 (threadprivate);
break;
default:
}
+try
+gfc_add_threadprivate (symbol_attribute * attr, const char *name, locus * where)
+{
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ if (attr->threadprivate)
+ {
+ duplicate_attr ("THREADPRIVATE", where);
+ return FAILURE;
+ }
+
+ attr->threadprivate = 1;
+ return check_conflict (attr, name, where);
+}
+
+
try
gfc_add_target (symbol_attribute * attr, locus * where)
{
goto fail;
if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->target && gfc_add_target (dest, where) == FAILURE)
goto fail;
if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
/* Common block and equivalence list handling
- Copyright (C) 2000, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
Contributed by Canqun Yang <canqun@nudt.edu.cn>
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "target.h"
#include "tree.h"
#include "toplev.h"
#include "tm.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-const.h"
+#include "rtl.h"
/* Holds a single variable in an equivalence set. */
{
decl = gfc_create_var (union_type, "equiv");
TREE_STATIC (decl) = 1;
+ GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
return decl;
}
TREE_ADDRESSABLE (decl) = 1;
TREE_USED (decl) = 1;
+ GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
/* The source location has been lost, and doesn't really matter.
We need to set it to something though. */
TREE_STATIC (decl) = 1;
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
DECL_USER_ALIGN (decl) = 0;
+ GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
gfc_set_decl_location (decl, &com->where);
+ if (com->threadprivate && targetm.have_tls)
+ DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
common_sym->backend_decl = pushdecl_top_level (decl);
build3 (COMPONENT_REF, TREE_TYPE (s->field),
decl, s->field, NULL_TREE));
DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
+ GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
if (s->sym->attr.assign)
{
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
+#include "rtl.h"
/* Only for gfc_trans_code. Shouldn't need to include this. */
#include "trans-stmt.h"
SET_DECL_VALUE_EXPR (decl, value);
DECL_HAS_VALUE_EXPR_P (decl) = 1;
+ GFC_DECL_CRAY_POINTEE (decl) = 1;
/* This is a fake variable just for debugging purposes. */
TREE_ASM_WRITTEN (decl) = 1;
}
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
TREE_STATIC (decl) = 1;
+
+ /* Handle threadprivate variables. */
+ if (sym->attr.threadprivate && targetm.have_tls
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
}
gimplify_function_tree (fndecl);
dump_function (TDI_generic, fndecl);
+ /* Generate errors for structured block violations. */
+ /* ??? Could be done as part of resolve_labels. */
+ if (flag_openmp)
+ diagnose_omp_structured_block_errors (fndecl);
+
/* Convert all nested functions to GIMPLE now. We do things in this order
so that items like VLA sizes are expanded properly in the context of the
correct function. */
NULL_TREE);
}
var = gfc_create_var (TREE_TYPE (decl), sym->name);
+ GFC_DECL_RESULT (var) = 1;
SET_DECL_VALUE_EXPR (var, decl);
DECL_HAS_VALUE_EXPR_P (var) = 1;
TREE_CHAIN (current_fake_result_decl)
DECL_EXTERNAL (decl) = 0;
TREE_PUBLIC (decl) = 0;
TREE_USED (decl) = 1;
+ GFC_DECL_RESULT (decl) = 1;
layout_decl (decl, 0);
--- /dev/null
+/* OpenMP directive translation -- generate GCC trees from gfc_code.
+ Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+ Contributed by Jakub Jelinek <jakub@redhat.com>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "tree-gimple.h"
+#include "ggc.h"
+#include "toplev.h"
+#include "real.h"
+#include "gfortran.h"
+#include "trans.h"
+#include "trans-stmt.h"
+#include "trans-types.h"
+#include "trans-array.h"
+#include "trans-const.h"
+#include "arith.h"
+
+
+/* True if OpenMP should privatize what this DECL points to rather
+ than the DECL itself. */
+
+bool
+gfc_omp_privatize_by_reference (tree decl)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ return true;
+
+ if (TREE_CODE (type) == POINTER_TYPE)
+ {
+ /* POINTER/ALLOCATABLE have aggregate types, all user variables
+ that have POINTER_TYPE type are supposed to be privatized
+ by reference. */
+ if (!DECL_ARTIFICIAL (decl))
+ return true;
+
+ /* Some arrays are expanded as DECL_ARTIFICIAL pointers
+ by the frontend. */
+ if (DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ return true;
+ }
+
+ return false;
+}
+
+/* True if OpenMP sharing attribute of DECL is predetermined. */
+
+enum omp_clause_default_kind
+gfc_omp_predetermined_sharing (tree decl)
+{
+ if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
+ return OMP_CLAUSE_DEFAULT_SHARED;
+
+ /* Cray pointees shouldn't be listed in any clauses and should be
+ gimplified to dereference of the corresponding Cray pointer.
+ Make them all private, so that they are emitted in the debug
+ information. */
+ if (GFC_DECL_CRAY_POINTEE (decl))
+ return OMP_CLAUSE_DEFAULT_PRIVATE;
+
+ /* COMMON and EQUIVALENCE decls are shared. They
+ are only referenced through DECL_VALUE_EXPR of the variables
+ contained in them. If those are privatized, they will not be
+ gimplified to the COMMON or EQUIVALENCE decls. */
+ if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
+ return OMP_CLAUSE_DEFAULT_SHARED;
+
+ if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
+ return OMP_CLAUSE_DEFAULT_SHARED;
+
+ return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
+}
+
+/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
+ disregarded in OpenMP construct, because it is going to be
+ remapped during OpenMP lowering. SHARED is true if DECL
+ is going to be shared, false if it is going to be privatized. */
+
+bool
+gfc_omp_disregard_value_expr (tree decl, bool shared)
+{
+ if (GFC_DECL_COMMON_OR_EQUIV (decl)
+ && DECL_HAS_VALUE_EXPR_P (decl))
+ {
+ tree value = DECL_VALUE_EXPR (decl);
+
+ if (TREE_CODE (value) == COMPONENT_REF
+ && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
+ && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
+ {
+ /* If variable in COMMON or EQUIVALENCE is privatized, return
+ true, as just that variable is supposed to be privatized,
+ not the whole COMMON or whole EQUIVALENCE.
+ For shared variables in COMMON or EQUIVALENCE, let them be
+ gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
+ from the same COMMON or EQUIVALENCE just one sharing of the
+ whole COMMON or EQUIVALENCE is enough. */
+ return ! shared;
+ }
+ }
+
+ if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
+ return ! shared;
+
+ return false;
+}
+
+/* Return true if DECL that is shared iff SHARED is true should
+ be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
+ flag set. */
+
+bool
+gfc_omp_private_debug_clause (tree decl, bool shared)
+{
+ if (GFC_DECL_CRAY_POINTEE (decl))
+ return true;
+
+ if (GFC_DECL_COMMON_OR_EQUIV (decl)
+ && DECL_HAS_VALUE_EXPR_P (decl))
+ {
+ tree value = DECL_VALUE_EXPR (decl);
+
+ if (TREE_CODE (value) == COMPONENT_REF
+ && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
+ && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
+ return shared;
+ }
+
+ return false;
+}
+
+/* Register language specific type size variables as potentially OpenMP
+ firstprivate variables. */
+
+void
+gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
+{
+ if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ int r;
+
+ gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
+ for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
+ {
+ omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
+ omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
+ omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
+ }
+ omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
+ omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
+ }
+}
+
+
+static inline tree
+gfc_trans_add_clause (tree node, tree tail)
+{
+ OMP_CLAUSE_CHAIN (node) = tail;
+ return node;
+}
+
+static tree
+gfc_trans_omp_variable (gfc_symbol *sym)
+{
+ tree t = gfc_get_symbol_decl (sym);
+
+ /* Special case for assigning the return value of a function.
+ Self recursive functions must have an explicit return value. */
+ if (t == current_function_decl && sym->attr.function
+ && (sym->result == sym))
+ t = gfc_get_fake_result_decl (sym);
+
+ /* Similarly for alternate entry points. */
+ else if (sym->attr.function && sym->attr.entry
+ && (sym->result == sym)
+ && sym->ns->proc_name->backend_decl == current_function_decl)
+ {
+ gfc_entry_list *el = NULL;
+
+ for (el = sym->ns->entries; el; el = el->next)
+ if (sym == el->sym)
+ {
+ t = gfc_get_fake_result_decl (sym);
+ break;
+ }
+ }
+
+ else if (sym->attr.result
+ && sym->ns->proc_name->backend_decl == current_function_decl
+ && sym->ns->proc_name->attr.entry_master
+ && !gfc_return_by_reference (sym->ns->proc_name))
+ t = gfc_get_fake_result_decl (sym);
+
+ return t;
+}
+
+static tree
+gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
+ tree list)
+{
+ for (; namelist != NULL; namelist = namelist->next)
+ if (namelist->sym->attr.referenced)
+ {
+ tree t = gfc_trans_omp_variable (namelist->sym);
+ if (t != error_mark_node)
+ {
+ tree node = build_omp_clause (code);
+ OMP_CLAUSE_DECL (node) = t;
+ list = gfc_trans_add_clause (node, list);
+ }
+ }
+ return list;
+}
+
+static void
+gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
+{
+ gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
+ gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
+ gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
+ gfc_expr *e1, *e2, *e3, *e4;
+ gfc_ref *ref;
+ tree decl, backend_decl;
+ locus old_loc = gfc_current_locus;
+ const char *iname;
+ try t;
+
+ decl = OMP_CLAUSE_DECL (c);
+ gfc_current_locus = where;
+
+ /* Create a fake symbol for init value. */
+ memset (&init_val_sym, 0, sizeof (init_val_sym));
+ init_val_sym.ns = sym->ns;
+ init_val_sym.name = sym->name;
+ init_val_sym.ts = sym->ts;
+ init_val_sym.attr.referenced = 1;
+ init_val_sym.declared_at = where;
+ backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
+ init_val_sym.backend_decl = backend_decl;
+
+ /* Create a fake symbol for the outer array reference. */
+ outer_sym = *sym;
+ outer_sym.as = gfc_copy_array_spec (sym->as);
+ outer_sym.attr.dummy = 0;
+ outer_sym.attr.result = 0;
+ outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
+
+ /* Create fake symtrees for it. */
+ symtree1 = gfc_new_symtree (&root1, sym->name);
+ symtree1->n.sym = sym;
+ gcc_assert (symtree1 == root1);
+
+ symtree2 = gfc_new_symtree (&root2, sym->name);
+ symtree2->n.sym = &init_val_sym;
+ gcc_assert (symtree2 == root2);
+
+ symtree3 = gfc_new_symtree (&root3, sym->name);
+ symtree3->n.sym = &outer_sym;
+ gcc_assert (symtree3 == root3);
+
+ /* Create expressions. */
+ e1 = gfc_get_expr ();
+ e1->expr_type = EXPR_VARIABLE;
+ e1->where = where;
+ e1->symtree = symtree1;
+ e1->ts = sym->ts;
+ e1->ref = ref = gfc_get_ref ();
+ ref->u.ar.where = where;
+ ref->u.ar.as = sym->as;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.dimen = 0;
+ t = gfc_resolve_expr (e1);
+ gcc_assert (t == SUCCESS);
+
+ e2 = gfc_get_expr ();
+ e2->expr_type = EXPR_VARIABLE;
+ e2->where = where;
+ e2->symtree = symtree2;
+ e2->ts = sym->ts;
+ t = gfc_resolve_expr (e2);
+ gcc_assert (t == SUCCESS);
+
+ e3 = gfc_copy_expr (e1);
+ e3->symtree = symtree3;
+ t = gfc_resolve_expr (e3);
+ gcc_assert (t == SUCCESS);
+
+ iname = NULL;
+ switch (OMP_CLAUSE_REDUCTION_CODE (c))
+ {
+ case PLUS_EXPR:
+ case MINUS_EXPR:
+ e4 = gfc_add (e3, e1);
+ break;
+ case MULT_EXPR:
+ e4 = gfc_multiply (e3, e1);
+ break;
+ case TRUTH_ANDIF_EXPR:
+ e4 = gfc_and (e3, e1);
+ break;
+ case TRUTH_ORIF_EXPR:
+ e4 = gfc_or (e3, e1);
+ break;
+ case EQ_EXPR:
+ e4 = gfc_eqv (e3, e1);
+ break;
+ case NE_EXPR:
+ e4 = gfc_neqv (e3, e1);
+ break;
+ case MIN_EXPR:
+ iname = "min";
+ break;
+ case MAX_EXPR:
+ iname = "max";
+ break;
+ case BIT_AND_EXPR:
+ iname = "iand";
+ break;
+ case BIT_IOR_EXPR:
+ iname = "ior";
+ break;
+ case BIT_XOR_EXPR:
+ iname = "ieor";
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ if (iname != NULL)
+ {
+ memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
+ intrinsic_sym.ns = sym->ns;
+ intrinsic_sym.name = iname;
+ intrinsic_sym.ts = sym->ts;
+ intrinsic_sym.attr.referenced = 1;
+ intrinsic_sym.attr.intrinsic = 1;
+ intrinsic_sym.attr.function = 1;
+ intrinsic_sym.result = &intrinsic_sym;
+ intrinsic_sym.declared_at = where;
+
+ symtree4 = gfc_new_symtree (&root4, iname);
+ symtree4->n.sym = &intrinsic_sym;
+ gcc_assert (symtree4 == root4);
+
+ e4 = gfc_get_expr ();
+ e4->expr_type = EXPR_FUNCTION;
+ e4->where = where;
+ e4->symtree = symtree4;
+ e4->value.function.isym = gfc_find_function (iname);
+ e4->value.function.actual = gfc_get_actual_arglist ();
+ e4->value.function.actual->expr = e3;
+ e4->value.function.actual->next = gfc_get_actual_arglist ();
+ e4->value.function.actual->next->expr = e1;
+ }
+ /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
+ e1 = gfc_copy_expr (e1);
+ e3 = gfc_copy_expr (e3);
+ t = gfc_resolve_expr (e4);
+ gcc_assert (t == SUCCESS);
+
+ /* Create the init statement list. */
+ OMP_CLAUSE_REDUCTION_INIT (c) = gfc_trans_assignment (e1, e2);
+
+ /* Create the merge statement list. */
+ OMP_CLAUSE_REDUCTION_MERGE (c) = gfc_trans_assignment (e3, e4);
+
+ /* And stick the placeholder VAR_DECL into the clause as well. */
+ OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
+
+ gfc_current_locus = old_loc;
+
+ gfc_free_expr (e1);
+ gfc_free_expr (e2);
+ gfc_free_expr (e3);
+ gfc_free_expr (e4);
+ gfc_free (symtree1);
+ gfc_free (symtree2);
+ gfc_free (symtree3);
+ if (symtree4)
+ gfc_free (symtree4);
+ gfc_free_array_spec (outer_sym.as);
+}
+
+static tree
+gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
+ enum tree_code reduction_code, locus where)
+{
+ for (; namelist != NULL; namelist = namelist->next)
+ if (namelist->sym->attr.referenced)
+ {
+ tree t = gfc_trans_omp_variable (namelist->sym);
+ if (t != error_mark_node)
+ {
+ tree node = build_omp_clause (OMP_CLAUSE_REDUCTION);
+ OMP_CLAUSE_DECL (node) = t;
+ OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
+ if (namelist->sym->attr.dimension)
+ gfc_trans_omp_array_reduction (node, namelist->sym, where);
+ list = gfc_trans_add_clause (node, list);
+ }
+ }
+ return list;
+}
+
+static tree
+gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
+ locus where)
+{
+ tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
+ int list;
+ enum omp_clause_code clause_code;
+ gfc_se se;
+
+ if (clauses == NULL)
+ return NULL_TREE;
+
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ {
+ gfc_namelist *n = clauses->lists[list];
+
+ if (n == NULL)
+ continue;
+ if (list >= OMP_LIST_REDUCTION_FIRST
+ && list <= OMP_LIST_REDUCTION_LAST)
+ {
+ enum tree_code reduction_code;
+ switch (list)
+ {
+ case OMP_LIST_PLUS:
+ reduction_code = PLUS_EXPR;
+ break;
+ case OMP_LIST_MULT:
+ reduction_code = MULT_EXPR;
+ break;
+ case OMP_LIST_SUB:
+ reduction_code = MINUS_EXPR;
+ break;
+ case OMP_LIST_AND:
+ reduction_code = TRUTH_ANDIF_EXPR;
+ break;
+ case OMP_LIST_OR:
+ reduction_code = TRUTH_ORIF_EXPR;
+ break;
+ case OMP_LIST_EQV:
+ reduction_code = EQ_EXPR;
+ break;
+ case OMP_LIST_NEQV:
+ reduction_code = NE_EXPR;
+ break;
+ case OMP_LIST_MAX:
+ reduction_code = MAX_EXPR;
+ break;
+ case OMP_LIST_MIN:
+ reduction_code = MIN_EXPR;
+ break;
+ case OMP_LIST_IAND:
+ reduction_code = BIT_AND_EXPR;
+ break;
+ case OMP_LIST_IOR:
+ reduction_code = BIT_IOR_EXPR;
+ break;
+ case OMP_LIST_IEOR:
+ reduction_code = BIT_XOR_EXPR;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ old_clauses = omp_clauses;
+ omp_clauses
+ = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
+ where);
+ continue;
+ }
+ switch (list)
+ {
+ case OMP_LIST_PRIVATE:
+ clause_code = OMP_CLAUSE_PRIVATE;
+ goto add_clause;
+ case OMP_LIST_SHARED:
+ clause_code = OMP_CLAUSE_SHARED;
+ goto add_clause;
+ case OMP_LIST_FIRSTPRIVATE:
+ clause_code = OMP_CLAUSE_FIRSTPRIVATE;
+ goto add_clause;
+ case OMP_LIST_LASTPRIVATE:
+ clause_code = OMP_CLAUSE_LASTPRIVATE;
+ goto add_clause;
+ case OMP_LIST_COPYIN:
+ clause_code = OMP_CLAUSE_COPYIN;
+ goto add_clause;
+ case OMP_LIST_COPYPRIVATE:
+ clause_code = OMP_CLAUSE_COPYPRIVATE;
+ /* FALLTHROUGH */
+ add_clause:
+ omp_clauses
+ = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
+ break;
+ default:
+ break;
+ }
+ }
+
+ if (clauses->if_expr)
+ {
+ tree if_var;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->if_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ if_var = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ c = build_omp_clause (OMP_CLAUSE_IF);
+ OMP_CLAUSE_IF_EXPR (c) = if_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->num_threads)
+ {
+ tree num_threads;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->num_threads);
+ gfc_add_block_to_block (block, &se.pre);
+ num_threads = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ c = build_omp_clause (OMP_CLAUSE_NUM_THREADS);
+ OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ chunk_size = NULL_TREE;
+ if (clauses->chunk_size)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->chunk_size);
+ gfc_add_block_to_block (block, &se.pre);
+ chunk_size = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+ }
+
+ if (clauses->sched_kind != OMP_SCHED_NONE)
+ {
+ c = build_omp_clause (OMP_CLAUSE_SCHEDULE);
+ OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
+ switch (clauses->sched_kind)
+ {
+ case OMP_SCHED_STATIC:
+ OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
+ break;
+ case OMP_SCHED_DYNAMIC:
+ OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
+ break;
+ case OMP_SCHED_GUIDED:
+ OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
+ break;
+ case OMP_SCHED_RUNTIME:
+ OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
+ {
+ c = build_omp_clause (OMP_CLAUSE_DEFAULT);
+ switch (clauses->default_sharing)
+ {
+ case OMP_DEFAULT_NONE:
+ OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
+ break;
+ case OMP_DEFAULT_SHARED:
+ OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
+ break;
+ case OMP_DEFAULT_PRIVATE:
+ OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->nowait)
+ {
+ c = build_omp_clause (OMP_CLAUSE_NOWAIT);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->ordered)
+ {
+ c = build_omp_clause (OMP_CLAUSE_ORDERED);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ return omp_clauses;
+}
+
+/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
+
+static tree
+gfc_trans_omp_code (gfc_code *code, bool force_empty)
+{
+ tree stmt;
+
+ pushlevel (0);
+ stmt = gfc_trans_code (code);
+ if (TREE_CODE (stmt) != BIND_EXPR)
+ {
+ if (!IS_EMPTY_STMT (stmt) || force_empty)
+ {
+ tree block = poplevel (1, 0, 0);
+ stmt = build3_v (BIND_EXPR, NULL, stmt, block);
+ }
+ else
+ poplevel (0, 0, 0);
+ }
+ else
+ poplevel (0, 0, 0);
+ return stmt;
+}
+
+
+static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
+static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
+
+static tree
+gfc_trans_omp_atomic (gfc_code *code)
+{
+ gfc_se lse;
+ gfc_se rse;
+ gfc_expr *expr2, *e;
+ gfc_symbol *var;
+ stmtblock_t block;
+ tree lhsaddr, type, rhs, x;
+ enum tree_code op = ERROR_MARK;
+ bool var_on_left = false;
+
+ code = code->block->next;
+ gcc_assert (code->op == EXEC_ASSIGN);
+ gcc_assert (code->next == NULL);
+ var = code->expr->symtree->n.sym;
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+ gfc_start_block (&block);
+
+ gfc_conv_expr (&lse, code->expr);
+ gfc_add_block_to_block (&block, &lse.pre);
+ type = TREE_TYPE (lse.expr);
+ lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
+
+ expr2 = code->expr2;
+ if (expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
+ expr2 = expr2->value.function.actual->expr;
+
+ if (expr2->expr_type == EXPR_OP)
+ {
+ gfc_expr *e;
+ switch (expr2->value.op.operator)
+ {
+ case INTRINSIC_PLUS:
+ op = PLUS_EXPR;
+ break;
+ case INTRINSIC_TIMES:
+ op = MULT_EXPR;
+ break;
+ case INTRINSIC_MINUS:
+ op = MINUS_EXPR;
+ break;
+ case INTRINSIC_DIVIDE:
+ if (expr2->ts.type == BT_INTEGER)
+ op = TRUNC_DIV_EXPR;
+ else
+ op = RDIV_EXPR;
+ break;
+ case INTRINSIC_AND:
+ op = TRUTH_ANDIF_EXPR;
+ break;
+ case INTRINSIC_OR:
+ op = TRUTH_ORIF_EXPR;
+ break;
+ case INTRINSIC_EQV:
+ op = EQ_EXPR;
+ break;
+ case INTRINSIC_NEQV:
+ op = NE_EXPR;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ e = expr2->value.op.op1;
+ if (e->expr_type == EXPR_FUNCTION
+ && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
+ e = e->value.function.actual->expr;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ {
+ expr2 = expr2->value.op.op2;
+ var_on_left = true;
+ }
+ else
+ {
+ e = expr2->value.op.op2;
+ if (e->expr_type == EXPR_FUNCTION
+ && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
+ e = e->value.function.actual->expr;
+ gcc_assert (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var);
+ expr2 = expr2->value.op.op1;
+ var_on_left = false;
+ }
+ gfc_conv_expr (&rse, expr2);
+ gfc_add_block_to_block (&block, &rse.pre);
+ }
+ else
+ {
+ gcc_assert (expr2->expr_type == EXPR_FUNCTION);
+ switch (expr2->value.function.isym->generic_id)
+ {
+ case GFC_ISYM_MIN:
+ op = MIN_EXPR;
+ break;
+ case GFC_ISYM_MAX:
+ op = MAX_EXPR;
+ break;
+ case GFC_ISYM_IAND:
+ op = BIT_AND_EXPR;
+ break;
+ case GFC_ISYM_IOR:
+ op = BIT_IOR_EXPR;
+ break;
+ case GFC_ISYM_IEOR:
+ op = BIT_XOR_EXPR;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ e = expr2->value.function.actual->expr;
+ gcc_assert (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var);
+
+ gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
+ gfc_add_block_to_block (&block, &rse.pre);
+ if (expr2->value.function.actual->next->next != NULL)
+ {
+ tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
+ gfc_actual_arglist *arg;
+
+ gfc_add_modify_expr (&block, accum, rse.expr);
+ for (arg = expr2->value.function.actual->next->next; arg;
+ arg = arg->next)
+ {
+ gfc_init_block (&rse.pre);
+ gfc_conv_expr (&rse, arg->expr);
+ gfc_add_block_to_block (&block, &rse.pre);
+ x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
+ gfc_add_modify_expr (&block, accum, x);
+ }
+
+ rse.expr = accum;
+ }
+
+ expr2 = expr2->value.function.actual->next->expr;
+ }
+
+ lhsaddr = save_expr (lhsaddr);
+ rhs = gfc_evaluate_now (rse.expr, &block);
+ x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr));
+
+ if (var_on_left)
+ x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
+ else
+ x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
+
+ if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
+ && TREE_CODE (type) != COMPLEX_TYPE)
+ x = build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
+
+ x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
+ gfc_add_expr_to_block (&block, x);
+
+ gfc_add_block_to_block (&block, &lse.pre);
+ gfc_add_block_to_block (&block, &rse.pre);
+
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_barrier (void)
+{
+ tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
+ return build_function_call_expr (decl, NULL);
+}
+
+static tree
+gfc_trans_omp_critical (gfc_code *code)
+{
+ tree name = NULL_TREE, stmt;
+ if (code->ext.omp_name != NULL)
+ name = get_identifier (code->ext.omp_name);
+ stmt = gfc_trans_code (code->block->next);
+ return build2_v (OMP_CRITICAL, stmt, name);
+}
+
+static tree
+gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
+ gfc_omp_clauses *clauses)
+{
+ gfc_se se;
+ tree dovar, stmt, from, to, step, type, init, cond, incr;
+ tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
+ stmtblock_t block;
+ stmtblock_t body;
+ int simple = 0;
+ bool dovar_found = false;
+
+ code = code->block->next;
+ gcc_assert (code->op == EXEC_DO);
+
+ if (pblock == NULL)
+ {
+ gfc_start_block (&block);
+ pblock = █
+ }
+
+ omp_clauses = gfc_trans_omp_clauses (pblock, clauses, code->loc);
+ if (clauses)
+ {
+ gfc_namelist *n;
+ for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; n = n->next)
+ if (code->ext.iterator->var->symtree->n.sym == n->sym)
+ break;
+ if (n == NULL)
+ for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
+ if (code->ext.iterator->var->symtree->n.sym == n->sym)
+ break;
+ if (n != NULL)
+ dovar_found = true;
+ }
+
+ /* Evaluate all the expressions in the iterator. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->ext.iterator->var);
+ gfc_add_block_to_block (pblock, &se.pre);
+ dovar = se.expr;
+ type = TREE_TYPE (dovar);
+ gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, code->ext.iterator->start);
+ gfc_add_block_to_block (pblock, &se.pre);
+ from = gfc_evaluate_now (se.expr, pblock);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, code->ext.iterator->end);
+ gfc_add_block_to_block (pblock, &se.pre);
+ to = gfc_evaluate_now (se.expr, pblock);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, code->ext.iterator->step);
+ gfc_add_block_to_block (pblock, &se.pre);
+ step = gfc_evaluate_now (se.expr, pblock);
+
+ /* Special case simple loops. */
+ if (integer_onep (step))
+ simple = 1;
+ else if (tree_int_cst_equal (step, integer_minus_one_node))
+ simple = -1;
+
+ /* Loop body. */
+ if (simple)
+ {
+ init = build2_v (MODIFY_EXPR, dovar, from);
+ cond = build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node,
+ dovar, to);
+ incr = fold_build2 (PLUS_EXPR, type, dovar, step);
+ incr = fold_build2 (MODIFY_EXPR, type, dovar, incr);
+ if (pblock != &block)
+ {
+ pushlevel (0);
+ gfc_start_block (&block);
+ }
+ gfc_start_block (&body);
+ }
+ else
+ {
+ /* STEP is not 1 or -1. Use:
+ for (count = 0; count < (to + step - from) / step; count++)
+ {
+ dovar = from + count * step;
+ body;
+ cycle_label:;
+ } */
+ tmp = fold_build2 (MINUS_EXPR, type, step, from);
+ tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
+ tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
+ tmp = gfc_evaluate_now (tmp, pblock);
+ count = gfc_create_var (type, "count");
+ init = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0));
+ cond = build2 (LT_EXPR, boolean_type_node, count, tmp);
+ incr = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1));
+ incr = fold_build2 (MODIFY_EXPR, type, count, incr);
+
+ if (pblock != &block)
+ {
+ pushlevel (0);
+ gfc_start_block (&block);
+ }
+ gfc_start_block (&body);
+
+ /* Initialize DOVAR. */
+ tmp = fold_build2 (MULT_EXPR, type, count, step);
+ tmp = build2 (PLUS_EXPR, type, from, tmp);
+ gfc_add_modify_expr (&body, dovar, tmp);
+ }
+
+ if (!dovar_found)
+ {
+ tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
+ OMP_CLAUSE_DECL (tmp) = dovar;
+ omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
+ }
+ if (!simple)
+ {
+ tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
+ OMP_CLAUSE_DECL (tmp) = count;
+ omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
+ }
+
+ /* Cycle statement is implemented with a goto. Exit statement must not be
+ present for this loop. */
+ cycle_label = gfc_build_label_decl (NULL_TREE);
+
+ /* Put these labels where they can be found later. We put the
+ labels in a TREE_LIST node (because TREE_CHAIN is already
+ used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
+ label in TREE_VALUE (backend_decl). */
+
+ code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
+
+ /* Main loop body. */
+ tmp = gfc_trans_omp_code (code->block->next, true);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Label for cycle statements (if needed). */
+ if (TREE_USED (cycle_label))
+ {
+ tmp = build1_v (LABEL_EXPR, cycle_label);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* End of loop body. */
+ stmt = make_node (OMP_FOR);
+
+ TREE_TYPE (stmt) = void_type_node;
+ OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
+ OMP_FOR_CLAUSES (stmt) = omp_clauses;
+ OMP_FOR_INIT (stmt) = init;
+ OMP_FOR_COND (stmt) = cond;
+ OMP_FOR_INCR (stmt) = incr;
+ gfc_add_expr_to_block (&block, stmt);
+
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_flush (void)
+{
+ tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
+ return build_function_call_expr (decl, NULL);
+}
+
+static tree
+gfc_trans_omp_master (gfc_code *code)
+{
+ tree stmt = gfc_trans_code (code->block->next);
+ if (IS_EMPTY_STMT (stmt))
+ return stmt;
+ return build1_v (OMP_MASTER, stmt);
+}
+
+static tree
+gfc_trans_omp_ordered (gfc_code *code)
+{
+ return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
+}
+
+static tree
+gfc_trans_omp_parallel (gfc_code *code)
+{
+ stmtblock_t block;
+ tree stmt, omp_clauses;
+
+ gfc_start_block (&block);
+ omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ code->loc);
+ stmt = gfc_trans_omp_code (code->block->next, true);
+ stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_do (gfc_code *code)
+{
+ stmtblock_t block, *pblock = NULL;
+ gfc_omp_clauses parallel_clauses, do_clauses;
+ tree stmt, omp_clauses = NULL_TREE;
+
+ gfc_start_block (&block);
+
+ memset (&do_clauses, 0, sizeof (do_clauses));
+ if (code->ext.omp_clauses != NULL)
+ {
+ memcpy (¶llel_clauses, code->ext.omp_clauses,
+ sizeof (parallel_clauses));
+ do_clauses.sched_kind = parallel_clauses.sched_kind;
+ do_clauses.chunk_size = parallel_clauses.chunk_size;
+ do_clauses.ordered = parallel_clauses.ordered;
+ parallel_clauses.sched_kind = OMP_SCHED_NONE;
+ parallel_clauses.chunk_size = NULL;
+ parallel_clauses.ordered = false;
+ omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses,
+ code->loc);
+ }
+ do_clauses.nowait = true;
+ if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
+ pblock = █
+ else
+ pushlevel (0);
+ stmt = gfc_trans_omp_do (code, pblock, &do_clauses);
+ if (TREE_CODE (stmt) != BIND_EXPR)
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
+ else
+ poplevel (0, 0, 0);
+ stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_sections (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_omp_clauses section_clauses;
+ tree stmt, omp_clauses;
+
+ memset (§ion_clauses, 0, sizeof (section_clauses));
+ section_clauses.nowait = true;
+
+ gfc_start_block (&block);
+ omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ code->loc);
+ pushlevel (0);
+ stmt = gfc_trans_omp_sections (code, §ion_clauses);
+ if (TREE_CODE (stmt) != BIND_EXPR)
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
+ else
+ poplevel (0, 0, 0);
+ stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_workshare (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_omp_clauses workshare_clauses;
+ tree stmt, omp_clauses;
+
+ memset (&workshare_clauses, 0, sizeof (workshare_clauses));
+ workshare_clauses.nowait = true;
+
+ gfc_start_block (&block);
+ omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ code->loc);
+ pushlevel (0);
+ stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
+ if (TREE_CODE (stmt) != BIND_EXPR)
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
+ else
+ poplevel (0, 0, 0);
+ stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
+{
+ stmtblock_t block, body;
+ tree omp_clauses, stmt;
+ bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
+
+ gfc_start_block (&block);
+
+ omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
+
+ gfc_init_block (&body);
+ for (code = code->block; code; code = code->block)
+ {
+ /* Last section is special because of lastprivate, so even if it
+ is empty, chain it in. */
+ stmt = gfc_trans_omp_code (code->next,
+ has_lastprivate && code->block == NULL);
+ if (! IS_EMPTY_STMT (stmt))
+ {
+ stmt = build1_v (OMP_SECTION, stmt);
+ gfc_add_expr_to_block (&body, stmt);
+ }
+ }
+ stmt = gfc_finish_block (&body);
+
+ stmt = build3_v (OMP_SECTIONS, stmt, omp_clauses, NULL);
+ gfc_add_expr_to_block (&block, stmt);
+
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
+{
+ tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
+ tree stmt = gfc_trans_omp_code (code->block->next, true);
+ stmt = build2_v (OMP_SINGLE, stmt, omp_clauses);
+ return stmt;
+}
+
+static tree
+gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
+{
+ /* XXX */
+ return gfc_trans_omp_single (code, clauses);
+}
+
+tree
+gfc_trans_omp_directive (gfc_code *code)
+{
+ switch (code->op)
+ {
+ case EXEC_OMP_ATOMIC:
+ return gfc_trans_omp_atomic (code);
+ case EXEC_OMP_BARRIER:
+ return gfc_trans_omp_barrier ();
+ case EXEC_OMP_CRITICAL:
+ return gfc_trans_omp_critical (code);
+ case EXEC_OMP_DO:
+ return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses);
+ case EXEC_OMP_FLUSH:
+ return gfc_trans_omp_flush ();
+ case EXEC_OMP_MASTER:
+ return gfc_trans_omp_master (code);
+ case EXEC_OMP_ORDERED:
+ return gfc_trans_omp_ordered (code);
+ case EXEC_OMP_PARALLEL:
+ return gfc_trans_omp_parallel (code);
+ case EXEC_OMP_PARALLEL_DO:
+ return gfc_trans_omp_parallel_do (code);
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ return gfc_trans_omp_parallel_sections (code);
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ return gfc_trans_omp_parallel_workshare (code);
+ case EXEC_OMP_SECTIONS:
+ return gfc_trans_omp_sections (code, code->ext.omp_clauses);
+ case EXEC_OMP_SINGLE:
+ return gfc_trans_omp_single (code, code->ext.omp_clauses);
+ case EXEC_OMP_WORKSHARE:
+ return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
+ default:
+ gcc_unreachable ();
+ }
+}
tree gfc_trans_deallocate (gfc_code *);
tree gfc_trans_deallocate_array (tree);
+/* trans-openmp.c */
+tree gfc_trans_omp_directive (gfc_code *);
+
/* trans-io.c */
tree gfc_trans_open (gfc_code *);
tree gfc_trans_close (gfc_code *);
res = gfc_trans_dt_end (code);
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_FLUSH:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ res = gfc_trans_omp_directive (code);
+ break;
+
default:
internal_error ("gfc_trans_code(): Bad statement code");
}
tree builtin_function (const char *, tree, int, enum built_in_class,
const char *, tree);
+/* In trans-openmp.c */
+bool gfc_omp_privatize_by_reference (tree);
+enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
+bool gfc_omp_disregard_value_expr (tree, bool);
+bool gfc_omp_private_debug_clause (tree, bool);
+struct gimplify_omp_ctx;
+void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree);
+
/* Runtime library function decls. */
extern GTY(()) tree gfor_fndecl_internal_malloc;
extern GTY(()) tree gfor_fndecl_internal_malloc64;
#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
#define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
#define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
+#define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
+#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
+#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
arg1, arg2)
#define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \
arg1, arg2, arg3)
+#define build4_v(code, arg1, arg2, arg3, arg4) build4(code, void_type_node, \
+ arg1, arg2, arg3, arg4)
/* This group of functions allows a caller to evaluate an expression from
the callee's interface. It establishes a mapping between the interface's
--- /dev/null
+/* Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
+
+/* This header contains a subset of ../builtin-types.def needed for
+ Fortran frontend builtins.
+
+ Before including this header, you must define the following macros:
+
+ DEF_PRIMITIVE_TYPE (ENUM, TYPE)
+
+ The ENUM is an identifier indicating which type is being defined.
+ TYPE is an expression for a `tree' that represents the type.
+
+ DEF_FUNCTION_TYPE_0 (ENUM, RETURN)
+ DEF_FUNCTION_TYPE_1 (ENUM, RETURN, ARG1)
+ DEF_FUNCTION_TYPE_2 (ENUM, RETURN, ARG1, ARG2)
+ DEF_FUNCTION_TYPE_3 (ENUM, RETURN, ARG1, ARG2, ARG3)
+ DEF_FUNCTION_TYPE_4 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4)
+ DEF_FUNCTION_TYPE_5 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5)
+ DEF_FUNCTION_TYPE_6 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6)
+ DEF_FUNCTION_TYPE_7 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7)
+
+ These macros describe function types. ENUM is as above. The
+ RETURN type is one of the enumerals already defined. ARG1, ARG2,
+ and ARG3 give the types of the arguments, similarly.
+
+ DEF_FUNCTION_TYPE_VAR_0 (ENUM, RETURN)
+
+ Similar, but for function types that take variable arguments.
+
+ DEF_POINTER_TYPE (ENUM, TYPE)
+
+ This macro describes a pointer type. ENUM is as above; TYPE is
+ the type pointed to. */
+
+DEF_PRIMITIVE_TYPE (BT_VOID, void_type_node)
+DEF_PRIMITIVE_TYPE (BT_BOOL, boolean_type_node)
+DEF_PRIMITIVE_TYPE (BT_INT, integer_type_node)
+DEF_PRIMITIVE_TYPE (BT_UINT, unsigned_type_node)
+DEF_PRIMITIVE_TYPE (BT_LONG, long_integer_type_node)
+
+DEF_PRIMITIVE_TYPE (BT_I1, builtin_type_for_size (BITS_PER_UNIT*1, 1))
+DEF_PRIMITIVE_TYPE (BT_I2, builtin_type_for_size (BITS_PER_UNIT*2, 1))
+DEF_PRIMITIVE_TYPE (BT_I4, builtin_type_for_size (BITS_PER_UNIT*4, 1))
+DEF_PRIMITIVE_TYPE (BT_I8, builtin_type_for_size (BITS_PER_UNIT*8, 1))
+DEF_PRIMITIVE_TYPE (BT_I16, builtin_type_for_size (BITS_PER_UNIT*16, 1))
+
+DEF_PRIMITIVE_TYPE (BT_PTR, ptr_type_node)
+DEF_PRIMITIVE_TYPE (BT_CONST_PTR, const_ptr_type_node)
+DEF_PRIMITIVE_TYPE (BT_VOLATILE_PTR,
+ build_pointer_type
+ (build_qualified_type (void_type_node,
+ TYPE_QUAL_VOLATILE)))
+
+DEF_POINTER_TYPE (BT_PTR_LONG, BT_LONG)
+DEF_POINTER_TYPE (BT_PTR_PTR, BT_PTR)
+DEF_FUNCTION_TYPE_0 (BT_FN_BOOL, BT_BOOL)
+DEF_FUNCTION_TYPE_0 (BT_FN_PTR, BT_PTR)
+DEF_FUNCTION_TYPE_0 (BT_FN_INT, BT_INT)
+DEF_FUNCTION_TYPE_0 (BT_FN_UINT, BT_UINT)
+DEF_FUNCTION_TYPE_0 (BT_FN_VOID, BT_VOID)
+
+DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTR, BT_VOID, BT_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTRPTR, BT_VOID, BT_PTR_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_VOID_VPTR, BT_VOID, BT_VOLATILE_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_UINT_UINT, BT_UINT, BT_UINT)
+
+DEF_POINTER_TYPE (BT_PTR_FN_VOID_PTR, BT_FN_VOID_PTR)
+
+DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_LONGPTR_LONGPTR,
+ BT_BOOL, BT_PTR_LONG, BT_PTR_LONG)
+DEF_FUNCTION_TYPE_2 (BT_FN_I1_VPTR_I1, BT_I1, BT_VOLATILE_PTR, BT_I1)
+DEF_FUNCTION_TYPE_2 (BT_FN_I2_VPTR_I2, BT_I2, BT_VOLATILE_PTR, BT_I2)
+DEF_FUNCTION_TYPE_2 (BT_FN_I4_VPTR_I4, BT_I4, BT_VOLATILE_PTR, BT_I4)
+DEF_FUNCTION_TYPE_2 (BT_FN_I8_VPTR_I8, BT_I8, BT_VOLATILE_PTR, BT_I8)
+DEF_FUNCTION_TYPE_2 (BT_FN_I16_VPTR_I16, BT_I16, BT_VOLATILE_PTR, BT_I16)
+
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I1_I1, BT_BOOL, BT_VOLATILE_PTR,
+ BT_I1, BT_I1)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I2_I2, BT_BOOL, BT_VOLATILE_PTR,
+ BT_I2, BT_I2)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I4_I4, BT_BOOL, BT_VOLATILE_PTR,
+ BT_I4, BT_I4)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I8_I8, BT_BOOL, BT_VOLATILE_PTR,
+ BT_I8, BT_I8)
+DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I16_I16, BT_BOOL, BT_VOLATILE_PTR,
+ BT_I16, BT_I16)
+DEF_FUNCTION_TYPE_3 (BT_FN_I1_VPTR_I1_I1, BT_I1, BT_VOLATILE_PTR, BT_I1, BT_I1)
+DEF_FUNCTION_TYPE_3 (BT_FN_I2_VPTR_I2_I2, BT_I2, BT_VOLATILE_PTR, BT_I2, BT_I2)
+DEF_FUNCTION_TYPE_3 (BT_FN_I4_VPTR_I4_I4, BT_I4, BT_VOLATILE_PTR, BT_I4, BT_I4)
+DEF_FUNCTION_TYPE_3 (BT_FN_I8_VPTR_I8_I8, BT_I8, BT_VOLATILE_PTR, BT_I8, BT_I8)
+DEF_FUNCTION_TYPE_3 (BT_FN_I16_VPTR_I16_I16, BT_I16, BT_VOLATILE_PTR,
+ BT_I16, BT_I16)
+DEF_FUNCTION_TYPE_3 (BT_FN_VOID_OMPFN_PTR_UINT, BT_VOID, BT_PTR_FN_VOID_PTR,
+ BT_PTR, BT_UINT)
+
+DEF_FUNCTION_TYPE_4 (BT_FN_VOID_OMPFN_PTR_UINT_UINT,
+ BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, BT_UINT)
+
+DEF_FUNCTION_TYPE_5 (BT_FN_BOOL_LONG_LONG_LONG_LONGPTR_LONGPTR,
+ BT_BOOL, BT_LONG, BT_LONG, BT_LONG,
+ BT_PTR_LONG, BT_PTR_LONG)
+
+DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_LONG_LONG_LONG_LONG_LONGPTR_LONGPTR,
+ BT_BOOL, BT_LONG, BT_LONG, BT_LONG, BT_LONG,
+ BT_PTR_LONG, BT_PTR_LONG)
+DEF_FUNCTION_TYPE_6 (BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG,
+ BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT,
+ BT_LONG, BT_LONG, BT_LONG)
+
+DEF_FUNCTION_TYPE_7 (BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG_LONG,
+ BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT,
+ BT_LONG, BT_LONG, BT_LONG, BT_LONG)
+
+DEF_FUNCTION_TYPE_VAR_0 (BT_FN_VOID_VAR, BT_VOID)
+2006-02-14 Jakub Jelinek <jakub@redhat.com>
+ Diego Novillo <dnovillo@redhat.com>
+ Uros Bizjak <uros@kss-loka.si>
+
+ * gfortran.dg/gomp: New directory.
+
2006-02-14 Richard Guenther <rguenther@suse.de>
PR tree-optimization/26258
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A1(N, A, B)
+ INTEGER I, N
+ REAL B(N), A(N)
+!$OMP PARALLEL DO !I is private by default
+ DO I=2,N
+ B(I) = (A(I) + A(I-1)) / 2.0
+ ENDDO
+!$OMP END PARALLEL DO
+ END SUBROUTINE A1
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A11_1(AA, BB, CC, DD, EE, FF, N)
+ INTEGER N
+ REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N), EE(N,N), FF(N,N)
+!$OMP PARALLEL
+!$OMP WORKSHARE
+ AA = BB
+ CC = DD
+ EE = FF
+!$OMP END WORKSHARE
+!$OMP END PARALLEL
+ END SUBROUTINE A11_1
--- /dev/null
+! { do-do compile }
+
+ SUBROUTINE A11_2(AA, BB, CC, DD, EE, FF, N)
+ INTEGER N
+ REAL AA(N,N), BB(N,N), CC(N,N)
+ REAL DD(N,N), EE(N,N), FF(N,N)
+!$OMP PARALLEL
+!$OMP WORKSHARE
+ AA = BB
+ CC = DD
+!$OMP END WORKSHARE NOWAIT
+!$OMP WORKSHARE
+ EE = FF
+!$OMP END WORKSHARE
+!$OMP END PARALLEL
+ END SUBROUTINE A11_2
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A11_3(AA, BB, CC, DD, N)
+ INTEGER N
+ REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N)
+ REAL R
+ R=0
+!$OMP PARALLEL
+!$OMP WORKSHARE
+ AA = BB
+!$OMP ATOMIC
+ R = R + SUM(AA)
+ CC = DD
+!$OMP END WORKSHARE
+!$OMP END PARALLEL
+ END SUBROUTINE A11_3
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A11_4(AA, BB, CC, DD, EE, FF, GG, HH, N)
+ INTEGER N
+ REAL AA(N,N), BB(N,N), CC(N,N)
+ REAL DD(N,N), EE(N,N), FF(N,N)
+ REAL GG(N,N), HH(N,N)
+!$OMP PARALLEL
+!$OMP WORKSHARE
+ AA = BB
+ CC = DD
+ WHERE (EE .ne. 0) FF = 1 / EE
+ GG = HH
+!$OMP END WORKSHARE
+!$OMP END PARALLEL
+ END SUBROUTINE A11_4
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A11_5(AA, BB, CC, DD, N)
+ INTEGER N
+ REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N)
+ INTEGER SHR
+!$OMP PARALLEL SHARED(SHR)
+!$OMP WORKSHARE
+ AA = BB
+ SHR = 1
+ CC = DD * SHR
+!$OMP END WORKSHARE
+!$OMP END PARALLEL
+ END SUBROUTINE A11_5
+
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A11_6_WRONG(AA, BB, CC, DD, N)
+ INTEGER N
+ REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N)
+ INTEGER PRI
+!$OMP PARALLEL PRIVATE(PRI)
+!$OMP WORKSHARE
+ AA = BB
+ PRI = 1
+ CC = DD * PRI
+!$OMP END WORKSHARE
+!$OMP END PARALLEL
+ END SUBROUTINE A11_6_WRONG
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A11_7(AA, BB, CC, N)
+ INTEGER N
+ REAL AA(N), BB(N), CC(N)
+!$OMP PARALLEL
+!$OMP WORKSHARE
+ AA(1:50) = BB(11:60)
+ CC(11:20) = AA(1:10)
+!$OMP END WORKSHARE
+!$OMP END PARALLEL
+ END SUBROUTINE A11_7
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A12( X, XOLD, N, TOL )
+ REAL X(*), XOLD(*), TOL
+ INTEGER N
+ INTEGER C, I, TOOBIG
+ REAL ERROR, Y, AVERAGE
+ EXTERNAL AVERAGE
+ C=0
+ TOOBIG = 1
+!$OMP PARALLEL
+ DO WHILE( TOOBIG > 0 )
+!$OMP DO PRIVATE(I)
+ DO I = 2, N-1
+ XOLD(I) = X(I)
+ ENDDO
+!$OMP SINGLE
+ TOOBIG = 0
+!$OMP END SINGLE
+!$OMP DO PRIVATE(I,Y,ERROR), REDUCTION(+:TOOBIG)
+ DO I = 2, N-1
+ Y = X(I)
+ X(I) = AVERAGE( XOLD(I-1), X(I), XOLD(I+1) )
+ ERROR = Y-X(I)
+ IF( ERROR > TOL .OR. ERROR < -TOL ) TOOBIG = TOOBIG+1
+ ENDDO
+!$OMP MASTER
+ C=C+1
+ PRINT *, "Iteration ", C, " TOOBIG=", TOOBIG
+!$OMP END MASTER
+ ENDDO
+!$OMP END PARALLEL
+ END SUBROUTINE A12
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A13(X, Y)
+ REAL X(*), Y(*)
+ INTEGER IX_NEXT, IY_NEXT
+!$OMP PARALLEL SHARED(X, Y) PRIVATE(IX_NEXT, IY_NEXT)
+!$OMP CRITICAL(XAXIS)
+ CALL DEQUEUE(IX_NEXT, X)
+!$OMP END CRITICAL(XAXIS)
+ CALL WORK(IX_NEXT, X)
+!$OMP CRITICAL(YAXIS)
+ CALL DEQUEUE(IY_NEXT,Y)
+!$OMP END CRITICAL(YAXIS)
+ CALL WORK(IY_NEXT, Y)
+!$OMP END PARALLEL
+ END SUBROUTINE A13
+
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A14()
+ INTEGER I
+ I=1
+!$OMP PARALLEL SECTIONS
+!$OMP SECTION
+!$OMP CRITICAL (NAME)
+!$OMP PARALLEL
+!$OMP SINGLE
+ I=I+1
+!$OMP END SINGLE
+!$OMP END PARALLEL
+!$OMP END CRITICAL (NAME)
+!$OMP END PARALLEL SECTIONS
+ END SUBROUTINE A14
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A17_1_WRONG()
+ INTEGER:: I
+ REAL:: R
+ EQUIVALENCE(I,R)
+!$OMP PARALLEL
+!$OMP ATOMIC
+ I=I+1
+!$OMP ATOMIC
+ R = R + 1.0
+! incorrect because I and R reference the same location
+! but have different types
+!$OMP END PARALLEL
+ END SUBROUTINE A17_1_WRONG
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE SUB()
+ COMMON /BLK/ R
+ REAL R
+!$OMP ATOMIC
+ R = R + 1.0
+ END SUBROUTINE SUB
+
+ SUBROUTINE A17_2_WRONG()
+ COMMON /BLK/ I
+ INTEGER I
+!$OMP PARALLEL
+!$OMP ATOMIC
+ I=I+1
+ CALL SUB()
+!$OMP END PARALLEL
+ END SUBROUTINE A17_2_WRONG
+
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A17_3_WRONG
+ INTEGER:: I
+ REAL:: R
+ EQUIVALENCE(I,R)
+!$OMP PARALLEL
+!$OMP ATOMIC
+ I=I+1
+! incorrect because I and R reference the same location
+! but have different types
+!$OMP END PARALLEL
+!$OMP PARALLEL
+!$OMP ATOMIC
+ R = R + 1.0
+! incorrect because I and R reference the same location
+! but have different types
+!$OMP END PARALLEL
+ END SUBROUTINE A17_3_WRONG
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WORK(I)
+ INTEGER I
+ END SUBROUTINE WORK
+ SUBROUTINE A21_WRONG(N)
+ INTEGER N
+ INTEGER I
+!$OMP DO ORDERED
+ DO I = 1, N
+! incorrect because an iteration may not execute more than one
+! ordered region
+!$OMP ORDERED
+ CALL WORK(I)
+!$OMP END ORDERED
+!$OMP ORDERED
+ CALL WORK(I+1)
+!$OMP END ORDERED
+ END DO
+ END SUBROUTINE A21_WRONG
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A21_GOOD(N)
+ INTEGER N
+!$OMP DO ORDERED
+ DO I = 1,N
+ IF (I <= 10) THEN
+!$OMP ORDERED
+ CALL WORK(I)
+!$OMP END ORDERED
+ ENDIF
+ IF (I > 10) THEN
+!$OMP ORDERED
+ CALL WORK(I+1)
+!$OMP END ORDERED
+ ENDIF
+ ENDDO
+ END SUBROUTINE A21_GOOD
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ INTEGER FUNCTION INCREMENT_COUNTER()
+ COMMON/A22_COMMON/COUNTER
+!$OMP THREADPRIVATE(/A22_COMMON/)
+ COUNTER = COUNTER +1
+ INCREMENT_COUNTER = COUNTER
+ RETURN
+ END FUNCTION INCREMENT_COUNTER
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ MODULE A22_MODULE
+ COMMON /T/ A
+ END MODULE A22_MODULE
+ SUBROUTINE A22_4_WRONG()
+ USE A22_MODULE
+!$OMP THREADPRIVATE(/T/) ! { dg-error "COMMON block" }
+ !non-conforming because /T/ not declared in A22_4_WRONG
+ END SUBROUTINE A22_4_WRONG
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ SUBROUTINE A22_5_WRONG()
+ COMMON /T/ A
+!$OMP THREADPRIVATE(/T/)
+ CONTAINS
+ SUBROUTINE A22_5S_WRONG()
+!$OMP PARALLEL COPYIN(/T/) ! { dg-error "COMMON block" }
+ !non-conforming because /T/ not declared in A22_5S_WRONG
+!$OMP END PARALLEL ! { dg-error "Unexpected" }
+ END SUBROUTINE A22_5S_WRONG
+ END SUBROUTINE A22_5_WRONG
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ SUBROUTINE A22_6_GOOD()
+ COMMON /T/ A
+!$OMP THREADPRIVATE(/T/)
+ CONTAINS
+ SUBROUTINE A22_6S_GOOD()
+ COMMON /T/ A
+!$OMP THREADPRIVATE(/T/)
+!$OMP PARALLEL COPYIN(/T/)
+!$OMP END PARALLEL
+ END SUBROUTINE A22_6S_GOOD
+ END SUBROUTINE A22_6_GOOD
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A23_1_GOOD()
+ COMMON /C/ X,Y
+ REAL X, Y
+!$OMP PARALLEL PRIVATE (/C/)
+ ! do work here
+!$OMP END PARALLEL
+!$OMP PARALLEL SHARED (X,Y)
+ ! do work here
+!$OMP END PARALLEL
+ END SUBROUTINE A23_1_GOOD
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A23_2_GOOD()
+ COMMON /C/ X,Y
+ REAL X, Y
+ INTEGER I
+!$OMP PARALLEL
+!$OMP DO PRIVATE(/C/)
+ DO I=1,1000
+ ! do work here
+ ENDDO
+!$OMP END DO
+!
+!$OMP DO PRIVATE(X)
+ DO I=1,1000
+ ! do work here
+ ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
+ END SUBROUTINE A23_2_GOOD
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A23_3_GOOD()
+ COMMON /C/ X,Y
+!$OMP PARALLEL PRIVATE (/C/)
+ ! do work here
+!$OMP END PARALLEL
+!$OMP PARALLEL SHARED (/C/)
+ ! do work here
+!$OMP END PARALLEL
+ END SUBROUTINE A23_3_GOOD
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A23_4_WRONG()
+ COMMON /C/ X,Y
+! Incorrect because X is a constituent element of C
+!$OMP PARALLEL PRIVATE(/C/), SHARED(X) ! { dg-error "Symbol 'x' present" }
+ ! do work here
+!$OMP END PARALLEL
+ END SUBROUTINE A23_4_WRONG
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A23_5_WRONG()
+ COMMON /C/ X,Y
+! Incorrect: common block C cannot be declared both
+! shared and private
+!$OMP PARALLEL PRIVATE (/C/), SHARED(/C/)
+ ! { dg-error "Symbol 'y' present" "" { target *-*-* } 7 }
+ ! { dg-error "Symbol 'x' present" "" { target *-*-* } 7 }
+ ! do work here
+!$OMP END PARALLEL
+ END SUBROUTINE A23_5_WRONG
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ SUBROUTINE A24(A)
+ INTEGER A
+ INTEGER X, Y, Z(1000)
+ INTEGER OMP_GET_NUM_THREADS
+ COMMON/BLOCKX/X
+ COMMON/BLOCKY/Y
+ COMMON/BLOCKZ/Z
+!$OMP THREADPRIVATE(/BLOCKX/)
+ INTEGER I, J
+ i=1
+!$OMP PARALLEL DEFAULT(NONE) PRIVATE(A) SHARED(Z) PRIVATE(J)
+ J = OMP_GET_NUM_THREADS();
+ ! O.K. - J is listed in PRIVATE clause
+ A = Z(J) ! O.K. - A is listed in PRIVATE clause
+ ! - Z is listed in SHARED clause
+ X=1 ! O.K. - X is THREADPRIVATE
+ Z(I) = Y ! Error - cannot reference I or Y here
+! { dg-error "'i' not specified" "" { target *-*-* } 20 } */
+! { dg-error "enclosing parallel" "" { target *-*-* } 14 } */
+! { dg-error "'y' not specified" "" { target *-*-* } 20 } */
+!$OMP DO firstprivate(y)
+ DO I = 1,10
+ Z(I) = Y ! O.K. - I is the loop iteration variable
+ ! Y is listed in FIRSTPRIVATE clause
+ END DO
+ Z(I) = Y ! Error - cannot reference I or Y here
+!$OMP END PARALLEL
+ END SUBROUTINE A24
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A25
+ INTEGER OMP_GET_THREAD_NUM
+ REAL A(20)
+ INTEGER MYTHREAD
+ !$OMP PARALLEL SHARED(A) PRIVATE(MYTHREAD)
+ MYTHREAD = OMP_GET_THREAD_NUM()
+ IF (MYTHREAD .EQ. 0) THEN
+ CALL SUB(A(1:10)) ! compiler may introduce writes to A(6:10)
+ ELSE
+ A(6:10) = 12
+ ENDIF
+ !$OMP END PARALLEL
+ END SUBROUTINE A25
+ SUBROUTINE SUB(X)
+ REAL X(*)
+ X(1:5) = 4
+ END SUBROUTINE SUB
--- /dev/null
+! { dg-do compile }
+
+ MODULE A26_2
+ REAL A
+ CONTAINS
+ SUBROUTINE G(K)
+ REAL K
+ A = K ! This is A in module A26_2, not the private
+ ! A in F
+ END SUBROUTINE G
+ SUBROUTINE F(N)
+ INTEGER N
+ REAL A
+ INTEGER I
+!$OMP PARALLEL DO PRIVATE(A)
+ DO I = 1,N
+ A=I
+ CALL G(A*2)
+ ENDDO
+!$OMP END PARALLEL DO
+ END SUBROUTINE F
+ END MODULE A26_2
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A27()
+ INTEGER I, A
+!$OMP PARALLEL PRIVATE(A)
+!$OMP PARALLEL DO PRIVATE(A)
+ DO I = 1, 10
+ ! do work here
+ END DO
+!$OMP END PARALLEL DO
+!$OMP END PARALLEL
+ END SUBROUTINE A27
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A30(N, A, B)
+ INTEGER N
+ REAL A(*), B(*)
+ INTEGER I
+!$OMP PARALLEL
+!$OMP DO LASTPRIVATE(I)
+ DO I=1,N-1
+ A(I) = B(I) + B(I+1)
+ ENDDO
+!$OMP END PARALLEL
+ A(I) = B(I) ! I has the value of N here
+ END SUBROUTINE A30
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A31_1(A, B, X, Y, N)
+ INTEGER N
+ REAL X(*), Y(*), A, B
+!$OMP PARALLEL DO PRIVATE(I) SHARED(X, N) REDUCTION(+:A)
+!$OMP& REDUCTION(MIN:B)
+ DO I=1,N
+ A = A + X(I)
+ B = MIN(B, Y(I))
+! Note that some reductions can be expressed in
+! other forms. For example, the MIN could be expressed as
+! IF (B > Y(I)) B = Y(I)
+ END DO
+ END SUBROUTINE A31_1
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE A31_2 (A, B, X, Y, N)
+ INTEGER N
+ REAL X(*), Y(*), A, B, A_P, B_P
+!$OMP PARALLEL SHARED(X, Y, N, A, B) PRIVATE(A_P, B_P)
+ A_P = 0.0
+ B_P = HUGE(B_P)
+!$OMP DO PRIVATE(I)
+ DO I=1,N
+ A_P = A_P + X(I)
+ B_P = MIN(B_P, Y(I))
+ ENDDO
+!$OMP END DO
+!$OMP CRITICAL
+ A = A + A_P
+ B = MIN(B, B_P)
+!$OMP END CRITICAL
+!$OMP END PARALLEL
+ END SUBROUTINE A31_2
--- /dev/null
+! { dg-do compile }
+ PROGRAM A31_3_WRONG
+ MAX = HUGE(0)
+ M=0
+ !$OMP PARALLEL DO REDUCTION(MAX: M) ! MAX is no longer the
+ ! intrinsic so this
+ ! is non-conforming
+! { dg-error "is not INTRINSIC procedure name" "" { target *-*-* } 5 } */
+ DO I = 1, 100
+ CALL SUB(M,I)
+ END DO
+ END PROGRAM A31_3_WRONG
+ SUBROUTINE SUB(M,I)
+ M = MAX(M,I)
+ END SUBROUTINE SUB
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ MODULE M
+ REAL, POINTER, SAVE :: WORK(:)
+ INTEGER :: SIZE
+ REAL :: TOL
+!$OMP THREADPRIVATE(WORK,SIZE,TOL)
+ END MODULE M
+ SUBROUTINE A32( T, N )
+ USE M
+ REAL :: T
+ INTEGER :: N
+ TOL = T
+ SIZE = N
+!$OMP PARALLEL COPYIN(TOL,SIZE)
+ CALL BUILD
+!$OMP END PARALLEL
+ END SUBROUTINE A32
+ SUBROUTINE BUILD
+ USE M
+ ALLOCATE(WORK(SIZE))
+ WORK = TOL
+ END SUBROUTINE BUILD
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ SUBROUTINE INIT(A,B)
+ REAL A, B
+ COMMON /XY/ X,Y
+!$OMP THREADPRIVATE (/XY/)
+!$OMP SINGLE
+ READ (11) A,B,X,Y
+!$OMP END SINGLE COPYPRIVATE (A,B,/XY/)
+ END SUBROUTINE INIT
--- /dev/null
+! { dg-do compile }
+
+ REAL FUNCTION READ_NEXT()
+ REAL, POINTER :: TMP
+!$OMP SINGLE
+ ALLOCATE (TMP)
+!$OMP END SINGLE COPYPRIVATE (TMP) ! copies the pointer only
+!$OMP MASTER
+ READ (11) TMP
+!$OMP END MASTER
+!$OMP BARRIER
+ READ_NEXT = TMP
+!$OMP BARRIER
+!$OMP SINGLE
+ DEALLOCATE (TMP)
+!$OMP END SINGLE NOWAIT
+ END FUNCTION READ_NEXT
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE S(N)
+ INTEGER N
+ REAL, DIMENSION(:), ALLOCATABLE :: A
+ REAL, DIMENSION(:), POINTER :: B
+ ALLOCATE (A(N))
+!$OMP SINGLE ! { dg-error "COPYPRIVATE clause object 'a'" }
+ ALLOCATE (B(N))
+ READ (11) A,B
+!$OMP END SINGLE COPYPRIVATE(A,B)
+ ! Variable A designates a private object
+ ! which has the same value in each thread
+ ! Variable B designates a shared object
+!$OMP BARRIER
+!$OMP SINGLE
+ DEALLOCATE (B)
+!$OMP END SINGLE NOWAIT
+ END SUBROUTINE S
+
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE WORK(I, J)
+ INTEGER I, J
+ END SUBROUTINE WORK
+ SUBROUTINE GOOD_NESTING(N)
+ INTEGER N
+ INTEGER I
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP DO
+ DO I = 1, N
+!$OMP PARALLEL SHARED(I,N)
+!$OMP DO
+ DO J = 1, N
+ CALL WORK(I,J)
+ END DO
+!$OMP END PARALLEL
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE GOOD_NESTING
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE WORK(I, J)
+ INTEGER I, J
+ END SUBROUTINE WORK
+ SUBROUTINE WORK1(I, N)
+ INTEGER J
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP DO
+ DO J = 1, N
+ CALL WORK(I,J)
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE WORK1
+ SUBROUTINE GOOD_NESTING2(N)
+ INTEGER N
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP DO
+ DO I = 1, N
+ CALL WORK1(I, N)
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE GOOD_NESTING2
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WORK(I, J)
+ INTEGER I, J
+ END SUBROUTINE WORK
+ SUBROUTINE WRONG1(N)
+ INTEGER N
+ INTEGER I,J
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP DO
+ DO I = 1, N
+!$OMP DO ! incorrect nesting of loop regions
+ DO J = 1, N
+ CALL WORK(I,J)
+ END DO
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE WRONG1
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WORK1(I,N)
+ INTEGER I, N
+ INTEGER J
+!$OMP DO ! incorrect nesting of loop regions
+ DO J = 1, N
+ CALL WORK(I,J)
+ END DO
+ END SUBROUTINE WORK1
+ SUBROUTINE WRONG2(N)
+ INTEGER N
+ INTEGER I
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP DO
+ DO I = 1, N
+ CALL WORK1(I,N)
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE WRONG2
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WRONG3(N)
+ INTEGER N
+ INTEGER I
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP DO
+ DO I = 1, N
+!$OMP SINGLE ! incorrect nesting of regions
+ CALL WORK(I, 1)
+!$OMP END SINGLE
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE WRONG3
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WRONG4(N)
+ INTEGER N
+ INTEGER I
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP DO
+ DO I = 1, N
+ CALL WORK(I, 1)
+! incorrect nesting of barrier region in a loop region
+!$OMP BARRIER
+ CALL WORK(I, 2)
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE WRONG4
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WRONG5(N)
+ INTEGER N
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP CRITICAL
+ CALL WORK(N,1)
+! incorrect nesting of barrier region in a critical region
+!$OMP BARRIER
+ CALL WORK(N,2)
+!$OMP END CRITICAL
+!$OMP END PARALLEL
+ END SUBROUTINE WRONG5
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WRONG6(N)
+ INTEGER N
+!$OMP PARALLEL DEFAULT(SHARED)
+!$OMP SINGLE
+ CALL WORK(N,1)
+! incorrect nesting of barrier region in a single region
+!$OMP BARRIER
+ CALL WORK(N,2)
+!$OMP END SINGLE
+!$OMP END PARALLEL
+ END SUBROUTINE WRONG6
+
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE DO_BY_16(X, IAM, IPOINTS)
+ REAL X(*)
+ INTEGER IAM, IPOINTS
+ END SUBROUTINE DO_BY_16
+ SUBROUTINE SUBA36(X, NPOINTS)
+ INTEGER NPOINTS
+ REAL X(NPOINTS)
+ INTEGER IAM, IPOINTS
+ EXTERNAL OMP_SET_DYNAMIC, OMP_SET_NUM_THREADS
+ INTEGER OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM
+ CALL OMP_SET_DYNAMIC(.FALSE.)
+ CALL OMP_SET_NUM_THREADS(16)
+!$OMP PARALLEL SHARED(X,NPOINTS) PRIVATE(IAM, IPOINTS)
+ IF (OMP_GET_NUM_THREADS() .NE. 16) THEN
+ STOP
+ ENDIF
+ IAM = OMP_GET_THREAD_NUM()
+ IPOINTS = NPOINTS/16
+ CALL DO_BY_16(X,IAM,IPOINTS)
+!$OMP END PARALLEL
+ END SUBROUTINE SUBA36
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE WORK(I)
+ INTEGER I
+ I=I+1
+ END SUBROUTINE WORK
+ SUBROUTINE INCORRECT()
+ INTEGER OMP_GET_NUM_THREADS
+ INTEGER I, NP
+ NP = OMP_GET_NUM_THREADS() !misplaced: will return 1
+!$OMP PARALLEL DO SCHEDULE(STATIC)
+ DO I = 0, NP-1
+ CALL WORK(I)
+ ENDDO
+!$OMP END PARALLEL DO
+ END SUBROUTINE INCORRECT
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE WORK(I)
+ INTEGER I
+ I=I+1
+ END SUBROUTINE WORK
+ SUBROUTINE CORRECT()
+ INTEGER OMP_GET_THREAD_NUM
+ INTEGER I
+!$OMP PARALLEL PRIVATE(I)
+ I = OMP_GET_THREAD_NUM()
+ CALL WORK(I)
+!$OMP END PARALLEL
+ END SUBROUTINE CORRECT
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WORK(I, J)
+ INTEGER I,J
+ END SUBROUTINE WORK
+ SUBROUTINE A6_GOOD()
+ INTEGER I, J
+ REAL A(1000)
+ DO 100 I = 1,10
+!$OMP DO
+ DO 100 J = 1,10
+ CALL WORK(I,J)
+ 100 CONTINUE ! !$OMP ENDDO implied here
+!$OMP DO
+ DO 200 J = 1,10
+200 A(I) = I + 1
+!$OMP ENDDO
+!$OMP DO
+ DO 300 I = 1,10
+ DO 300 J = 1,10
+ CALL WORK(I,J)
+300 CONTINUE
+!$OMP ENDDO
+ END SUBROUTINE A6_GOOD
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE WORK(I, J)
+ INTEGER I,J
+ END SUBROUTINE WORK
+
+ SUBROUTINE A6_WRONG
+ INTEGER I, J
+ DO 100 I = 1,10
+!$OMP DO
+ DO 100 J = 1,10
+ CALL WORK(I,J)
+ 100 CONTINUE
+!$OMP ENDDO ! { dg-error "Unexpected ..OMP END DO statement" }
+ END SUBROUTINE A6_WRONG
--- /dev/null
+! { dg-do compile }
+SUBROUTINE A7_1(A,N)
+INTEGER OMP_GET_THREAD_NUM
+REAL A(*)
+INTEGER I, MYOFFSET, N
+!$OMP PARALLEL PRIVATE(MYOFFSET)
+ MYOFFSET = OMP_GET_THREAD_NUM()*N
+ DO I = 1, N
+ A(MYOFFSET+I) = FLOAT(I)
+ ENDDO
+!$OMP END PARALLEL
+END SUBROUTINE A7_1
--- /dev/null
+! { dg-do compile }
+
+SUBROUTINE A7_2(A,B,N,I1,I2)
+REAL A(*), B(*)
+INTEGER I1, I2, N
+!$OMP PARALLEL SHARED(A,B,I1,I2)
+!$OMP SECTIONS
+!$OMP SECTION
+ DO I1 = I1, N
+ IF (A(I1).NE.0.0) EXIT
+ ENDDO
+!$OMP SECTION
+ DO I2 = I2, N
+ IF (B(I2).NE.0.0) EXIT
+ ENDDO
+!$OMP END SECTIONS
+!$OMP SINGLE
+ IF (I1.LE.N) PRINT *, "ITEMS IN A UP TO ", I1, " ARE ALL ZERO."
+ IF (I2.LE.N) PRINT *, "ITEMS IN B UP TO ", I2, " ARE ALL ZERO."
+!$OMP END SINGLE
+!$OMP END PARALLEL
+END SUBROUTINE A7_2
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A8(N, M, A, B, Y, Z)
+ INTEGER N, M
+ REAL A(*), B(*), Y(*), Z(*)
+ INTEGER I
+!$OMP PARALLEL
+!$OMP DO
+ DO I=2,N
+ B(I) = (A(I) + A(I-1)) / 2.0
+ ENDDO
+!$OMP END DO NOWAIT
+!$OMP DO
+ DO I=1,M
+ Y(I) = SQRT(Z(I))
+ ENDDO
+!$OMP END DO NOWAIT
+!$OMP END PARALLEL
+ END SUBROUTINE A8
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE A9()
+!$OMP PARALLEL SECTIONS
+!$OMP SECTION
+ CALL XAXIS()
+!$OMP SECTION
+ CALL YAXIS()
+!$OMP SECTION
+ CALL ZAXIS()
+!$OMP END PARALLEL SECTIONS
+ END SUBROUTINE A9
--- /dev/null
+! { dg-do compile }
+
+!$omp parallel
+!$omp critical
+ goto 10 ! { dg-error "invalid exit" }
+!$omp end critical
+ 10 x = 1
+!$omp end parallel
+
+ end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -fcray-pointer" }
+
+ integer :: a, b, c, d, i
+ pointer (ip1, a)
+ pointer (ip2, b)
+ pointer (ip3, c)
+ pointer (ip4, d)
+
+!$omp parallel shared (a) ! { dg-error "Cray pointee 'a' in SHARED clause" }
+!$omp end parallel
+
+!$omp parallel private (b) ! { dg-error "Cray pointee 'b' in PRIVATE clause" }
+!$omp end parallel
+
+!$omp parallel firstprivate (c) ! { dg-error "Cray pointee 'c' in FIRSTPRIVATE clause" }
+!$omp end parallel
+
+!$omp parallel do lastprivate (d) ! { dg-error "Cray pointee 'd' in LASTPRIVATE clause" }
+ do i = 1, 10
+ if (i .eq. 10) d = 1
+ end do
+!$omp end parallel do
+
+!$omp parallel reduction (+: a) ! { dg-error "Cray pointee 'a' in REDUCTION clause" }
+!$omp end parallel
+
+ ip1 = loc (i)
+!$omp parallel shared (ip1)
+ a = 2
+!$omp end parallel
+
+!$omp parallel private (ip2, i)
+ ip2 = loc (i)
+ b = 1
+!$omp end parallel
+
+ ip3 = loc (i)
+!$omp parallel firstprivate (ip3) ! { dg-error "Cray pointer 'ip3' in FIRSTPRIVATE clause" }
+!$omp end parallel
+
+!$omp parallel do lastprivate (ip4) ! { dg-error "Cray pointer 'ip4' in LASTPRIVATE clause" }
+ do i = 1, 10
+ if (i .eq. 10) ip4 = loc (i)
+ end do
+!$omp end parallel do
+
+!$omp parallel reduction (+: ip1) ! { dg-error "Cray pointer 'ip1' in REDUCTION clause" }
+!$omp end parallel
+
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -fcray-pointer" }
+! { dg-require-effective-target tls }
+
+module crayptr2
+ integer :: e ! { dg-error "CRAY POINTEE attribute conflicts with THREADPRIVATE" }
+ pointer (ip5, e)
+
+! The standard is not very clear about this.
+! Certainly, Cray pointees can't be SAVEd, nor they can be
+! in COMMON, so the only way to make threadprivate Cray pointees would
+! be if they are module variables. But threadprivate pointees don't
+! make any sense anyway.
+
+!$omp threadprivate (e)
+
+end module crayptr2
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -fcray-pointer" }
+
+ integer :: a, b
+ pointer (ip, a)
+
+ b = 2
+ ip = loc (b)
+!$omp parallel default (none) shared (ip)
+ a = 1
+!$omp end parallel
+
+!$omp parallel default (none) private (ip, b)
+ b = 3
+ ip = loc (b)
+ a = 1
+!$omp end parallel
+
+!$omp parallel default (none) ! { dg-error "enclosing parallel" }
+ a = 1 ! { dg-error "'ip' not specified in enclosing parallel" }
+!$omp end parallel
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -fcray-pointer" }
+
+subroutine foo (n)
+ integer :: a, b (38), n
+ pointer (ip, a (n + 1))
+
+ b = 2
+ n = 36
+ ip = loc (b)
+!$omp parallel default (none) shared (ip)
+!$omp parallel default (none) shared (ip)
+ a = 1
+!$omp end parallel
+!$omp end parallel
+
+!$omp parallel default (none)
+!$omp parallel default (none) private (ip, b)
+ b = 3
+ ip = loc (b)
+ a = 1
+!$omp end parallel
+!$omp end parallel
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-O -fopenmp -fdump-tree-omplower" }
+
+subroutine foo (i, j, k, s, a)
+ integer :: i, j, k, s, a(100), l
+!$omp parallel do schedule (dynamic, s * 2)
+ do 100, l = j, k
+100 a(l) = i
+!$omp parallel do schedule (dynamic, s * 2)
+ do 101, l = j, k, 3
+101 a(l) = i + 1
+end subroutine foo
+
+subroutine bar (i, j, k, s, a)
+ integer :: i, j, k, s, a(100), l
+!$omp parallel do schedule (guided, s * 2)
+ do 100, l = j, k
+100 a(l) = i
+!$omp parallel do schedule (guided, s * 2)
+ do 101, l = j, k, 3
+101 a(l) = i + 1
+end subroutine bar
+
+! { dg-final { scan-tree-dump-times "GOMP_parallel_loop_dynamic_start" 2 "omplower" { xfail *-*-* } } }
+! { dg-final { scan-tree-dump-times "GOMP_parallel_loop_guided_start" 2 "omplower" { xfail *-*-* } } }
+! { dg-final { cleanup-tree-dump "omplower" } }
--- /dev/null
+C PR fortran/24493
+C { dg-do compile }
+C { dg-require-effective-target tls }
+ INTEGER I, J, K, L, M
+C$OMP THREADPRIVATE(I)
+C SOME COMMENT
+ SAVE I ! ANOTHER COMMENT
+C$OMP THREADPRIVATE
+C$OMP+(J) ! OMP DIRECTIVE COMMENT
+* NORMAL COMMENT
+c$OMP THREAD! COMMENT
+C$OMP&PRIVATE! COMMENT
+*$OMP+ (K)
+C$OMP THREADPRIVATE (L ! COMMENT
+*$OMP& , M)
+ SAVE J, K, L, M
+ I = 1
+ J = 2
+ K = 3
+ L = 4
+ M = 5
+ END
--- /dev/null
+! { dg-require-effective-target tls }
+
+subroutine foo
+integer, save :: i ! Some comment
+!$omp threadpri&
+ !$omp&vate (i)
+i = 1
+end subroutine
--- /dev/null
+# GCC testsuite that uses the `dg.exp' driver.
+
+# Load support procs.
+load_lib gfortran-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+# Main loop.
+gfortran-dg-runtest [lsort \
+ [find $srcdir/$subdir *.\[fF\]{,90,95} ] ] " -fopenmp"
+
+# All done.
+dg-finish
--- /dev/null
+! { dg-do compile }
+subroutine test_atomic
+ integer (kind = 4) :: a
+ integer :: b
+ real :: c, f
+ double precision :: d
+ integer, dimension (10) :: e
+ a = 1
+ b = 2
+ c = 3
+ d = 4
+ e = 5
+ f = 6
+!$omp atomic
+ a = a + 4
+!$omp atomic
+ b = 4 - b
+!$omp atomic
+ c = c * 2
+!$omp atomic
+ d = 2 / d
+!$omp atomic
+ e = 1 ! { dg-error "must set a scalar variable" }
+!$omp atomic
+ a = a ** 8 ! { dg-error "assignment operator must be" }
+!$omp atomic
+ b = b + 3 + b ! { dg-error "cannot reference" }
+!$omp atomic
+ c = c - f + 1 ! { dg-error "not mathematically equivalent to" }
+!$omp atomic
+ a = ishft (a, 1) ! { dg-error "assignment intrinsic must be" }
+!$omp atomic
+ c = min (c, 2.1, c) ! { dg-error "intrinsic arguments except one" }
+!$omp atomic
+ a = max (b, e(1)) ! { dg-error "intrinsic argument must be 'a'" }
+!$omp atomic
+ d = 12 ! { dg-error "assignment must have an operator" }
+end subroutine test_atomic
--- /dev/null
+! { dg-do compile }
+ subroutine test1
+ integer :: i, j, k, l
+ common /b/ j, k
+!$omp parallel shared (i) private (/b/)
+!$omp end parallel
+!$omp parallel do shared (/b/), firstprivate (i), lastprivate (i)
+ do l = 1, 10
+ end do
+!$omp end parallel do
+!$omp parallel shared (j) private (/b/) ! { dg-error "'j' present on multiple clauses" }
+!$omp end parallel
+!$omp parallel shared (j, j) private (i) ! { dg-error "'j' present on multiple clauses" }
+!$omp end parallel
+!$omp parallel firstprivate (i, j, i) ! { dg-error "'i' present on multiple clauses" }
+!$omp end parallel
+!$omp parallel shared (i) private (/b/, /b/) ! { dg-error "'\[jk\]' present on multiple clauses" }
+!$omp end parallel
+!$omp parallel shared (i) reduction (+ : i, j) ! { dg-error "'i' present on multiple clauses" }
+!$omp end parallel
+!$omp parallel do shared (/b/), firstprivate (/b/), lastprivate (i) ! { dg-error "'\[jk\]' present on multiple clauses" }
+ do l = 1, 10
+ end do
+!$omp end parallel do
+ end subroutine test1
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -std=gnu" }
+subroutine foo
+ integer :: i, j
+ integer, dimension (30) :: a
+ double precision :: d
+ i = 0
+!$omp do private (i)
+ do 100 ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+ if (i .gt. 0) exit ! { dg-error "EXIT statement" }
+100 i = i + 1
+ i = 0
+!$omp do private (i)
+ do ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+ if (i .gt. 0) exit ! { dg-error "EXIT statement" }
+ i = i + 1
+ end do
+ i = 0
+!$omp do private (i)
+ do 200 while (i .lt. 4) ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+200 i = i + 1
+!$omp do private (i)
+ do while (i .lt. 8) ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+ i = i + 1
+ end do
+!$omp do
+ do 300 d = 1, 30, 6 ! { dg-warning "Obsolete: REAL DO loop iterator" }
+ i = d
+300 a(i) = 1
+!$omp do
+ do d = 1, 30, 5 ! { dg-warning "Obsolete: REAL DO loop iterator" }
+ i = d
+ a(i) = 2
+ end do
+!$omp do
+ do i = 1, 30
+ if (i .eq. 16) exit ! { dg-error "EXIT statement" }
+ end do
+!$omp do
+outer: do i = 1, 30
+ do j = 5, 10
+ if (i .eq. 6 .and. j .eq. 7) exit outer ! { dg-error "EXIT statement" }
+ end do
+ end do outer
+last: do i = 1, 30
+!$omp parallel
+ if (i .eq. 21) exit last ! { dg-error "leaving OpenMP structured block" }
+!$omp end parallel
+ end do last
+!$omp parallel do shared (i)
+ do i = 1, 30, 2 ! { dg-error "iteration variable present on clause" }
+ a(i) = 5
+ end do
+!$omp end parallel do
+end subroutine
+! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 27 }
+! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 31 }
--- /dev/null
+! { dg-require-effective-target tls }
+ module omp_threadprivate1
+ common /T/ a
+ end module omp_threadprivate1
+ subroutine bad1
+ use omp_threadprivate1
+!$omp threadprivate (/T/) ! { dg-error "not found" }
+ end subroutine bad1
+ subroutine bad2
+ common /S/ b
+!$omp threadprivate (/S/)
+ contains
+ subroutine bad3
+!$omp parallel copyin (/T/) ! { dg-error "not found" }
+!$omp end parallel ! { dg-error "" }
+ end subroutine bad3
+ end subroutine bad2
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+ subroutine bad1
+ double precision :: d ! { dg-error "isn't SAVEd" }
+!$omp threadprivate (d)
+ end subroutine bad1
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+subroutine foo (ia1)
+integer :: i1, i2, i3
+integer, dimension (*) :: ia1
+integer, dimension (10) :: ia2
+real :: r1
+real, dimension (5) :: ra1
+double precision :: d1
+double precision, dimension (4) :: da1
+complex :: c1
+complex, dimension (7) :: ca1
+logical :: l1
+logical, dimension (3) :: la1
+character (5) :: a1
+type t
+ integer :: i
+end type
+type(t) :: t1
+type(t), dimension (2) :: ta1
+real, pointer :: p1 => NULL()
+integer, allocatable :: aa1 (:,:)
+save i2
+!$omp threadprivate (i2)
+common /blk/ i1
+
+!$omp parallel reduction (+:i3, ia2, r1, ra1, d1, da1, c1, ca1)
+!$omp end parallel
+!$omp parallel reduction (*:i3, ia2, r1, ra1, d1, da1, c1, ca1)
+!$omp end parallel
+!$omp parallel reduction (-:i3, ia2, r1, ra1, d1, da1, c1, ca1)
+!$omp end parallel
+!$omp parallel reduction (.and.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (.or.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (.eqv.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (.neqv.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (min:i3, ia2, r1, ra1, d1, da1)
+!$omp end parallel
+!$omp parallel reduction (max:i3, ia2, r1, ra1, d1, da1)
+!$omp end parallel
+!$omp parallel reduction (iand:i3, ia2)
+!$omp end parallel
+!$omp parallel reduction (ior:i3, ia2)
+!$omp end parallel
+!$omp parallel reduction (ieor:i3, ia2)
+!$omp end parallel
+!$omp parallel reduction (+:/blk/) ! { dg-error "Syntax error" }
+!$omp end parallel ! { dg-error "Unexpected" }
+!$omp parallel reduction (+:i2) ! { dg-error "THREADPRIVATE object" }
+!$omp end parallel
+!$omp parallel reduction (*:p1) ! { dg-error "POINTER object" }
+!$omp end parallel
+!$omp parallel reduction (-:aa1) ! { dg-error "is ALLOCATABLE" }
+!$omp end parallel
+!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" }
+!$omp end parallel
+!$omp parallel reduction (+:l1) ! { dg-error "is LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (*:la1) ! { dg-error "is LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (-:a1) ! { dg-error "is CHARACTER" }
+!$omp end parallel
+!$omp parallel reduction (+:t1) ! { dg-error "is TYPE" }
+!$omp end parallel
+!$omp parallel reduction (*:ta1) ! { dg-error "is TYPE" }
+!$omp end parallel
+!$omp parallel reduction (.and.:i3) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.or.:ia2) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.eqv.:r1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.neqv.:ra1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.and.:d1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.or.:da1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.eqv.:c1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.neqv.:ca1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.and.:a1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.or.:t1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.eqv.:ta1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (min:c1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:ca1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:l1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (min:la1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:a1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (min:t1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:ta1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (iand:r1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:ra1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ieor:d1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:da1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (iand:c1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:ca1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ieor:l1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (iand:la1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:a1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ieor:t1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (iand:ta1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+
+end subroutine
--- /dev/null
+! { dg-do compile }
+
+subroutine f1
+ integer :: i
+ i = 0
+!$omp parallel reduction (ior:i)
+ i = ior (i, 3)
+!$omp end parallel
+!$omp parallel reduction (ior:i)
+ i = ior (i, 16)
+!$omp end parallel
+end subroutine f1
+subroutine f2
+ integer :: i
+ i = ior (2, 4)
+!$omp parallel reduction (ior:i)
+ i = ior (i, 3)
+!$omp end parallel
+end subroutine f2
+subroutine f3
+ integer :: i
+ i = 6
+!$omp parallel reduction (ior:i)
+ i = ior (i, 3)
+!$omp end parallel
+end subroutine f3
+subroutine f4
+ integer :: i, ior
+ i = 6
+!$omp parallel reduction (ior:i)
+ i = ior (i, 3)
+!$omp end parallel
+end subroutine f4
--- /dev/null
+! { dg-do compile }
+
+module mreduction3
+ interface
+ function ior (a, b)
+ integer :: ior, a, b
+ end function
+ end interface
+contains
+ function iand (a, b)
+ integer :: iand, a, b
+ iand = a + b
+ end function
+end module mreduction3
+subroutine f1
+ integer :: i, ior
+ ior = 6
+ i = 6
+!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp end parallel
+end subroutine f1
+subroutine f2
+ integer :: i
+ interface
+ function ior (a, b)
+ integer :: ior, a, b
+ end function
+ end interface
+ i = 6
+!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+ i = ior (i, 3)
+!$omp end parallel
+end subroutine f2
+subroutine f3
+ integer :: i
+ interface
+ function ior (a, b)
+ integer :: ior, a, b
+ end function
+ end interface
+ intrinsic ior
+ i = 6
+!$omp parallel reduction (ior:i)
+ i = ior (i, 3)
+!$omp end parallel
+end subroutine f3
+subroutine f4
+ integer :: i, ior
+ i = 6
+!$omp parallel reduction (ior:i)
+ ior = 4 ! { dg-error "Expected VARIABLE" }
+!$omp end parallel
+end subroutine f4
+subroutine f5
+ use mreduction3
+ integer :: i
+ i = 6
+!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+ i = ior (i, 7)
+!$omp end parallel
+end subroutine f5
+subroutine f6
+ use mreduction3
+ integer :: i
+ i = 6
+!$omp parallel reduction (iand:i) ! { dg-error "is not INTRINSIC procedure name" }
+ i = iand (i, 18)
+!$omp end parallel
+end subroutine f6
--- /dev/null
+! { dg-do compile }
+! { dg-require-effective-target tls }
+
+ integer :: thrpriv, thr, i, j, s, g1, g2, m
+ integer, dimension (6) :: p
+ common /thrblk/ thr
+ common /gblk/ g1
+ save thrpriv, g2
+!$omp threadprivate (/thrblk/, thrpriv)
+ s = 1
+!$omp parallel do default (none) &
+!$omp & private (p) shared (s) ! { dg-error "enclosing parallel" }
+ do i = 1, 64
+ call foo (thrpriv) ! Predetermined - threadprivate
+ call foo (thr) ! Predetermined - threadprivate
+ call foo (i) ! Predetermined - omp do iteration var
+ do j = 1, 64 ! Predetermined - sequential loop
+ call foo (j) ! iteration variable
+ end do
+ call bar ((/ (k * 4, k = 1, 8) /)) ! Predetermined - implied do
+ forall (l = 1 : i) &! Predetermined - forall indice
+ p(l) = 6 ! Explicitly determined - private
+ call foo (s) ! Explicitly determined - shared
+ call foo (g1) ! { dg-error "not specified in" }
+ call foo (g2) ! { dg-error "not specified in" }
+ call foo (m) ! { dg-error "not specified in" }
+ end do
+end
--- /dev/null
+ integer :: i, j, k, l
+ integer, dimension (10, 10) :: a
+!$omp parallel do default (none) shared (a)
+ do i = 1, 10
+ j = 4
+ do j = 1, 10
+ a(i, j) = i + j
+ end do
+ j = 8
+ end do
+!$omp end parallel do
+!$omp parallel default (none) shared (a) ! { dg-error "enclosing parallel" }
+ i = 1
+ j = 1
+ k = 1
+ l = 1 ! { dg-error "not specified in" }
+ do i = 1, 10
+ a(i, 1) = 1
+ end do
+!$omp critical
+ do j = 1, 10
+ a(1, j) = j
+ end do
+!$omp end critical
+!$omp single
+ do k = 1, 10
+ a(k, k) = k
+ end do
+!$omp end single
+!$omp end parallel
+!$omp parallel default (none) shared (a)
+ i = 1
+ j = 1
+ k = 1
+!$omp parallel default (none) shared (a)
+ i = 1
+ j = 1
+ k = 1
+ do i = 1, 10
+ a(i, 1) = 1
+ end do
+!$omp critical
+ do j = 1, 10
+ a(1, j) = j
+ end do
+!$omp end critical
+!$omp single
+ do k = 1, 10
+ a(k, k) = k
+ end do
+!$omp end single
+!$omp end parallel
+ i = 1
+ j = 1
+ k = 1
+!$omp end parallel
+!$omp parallel default (none) shared (a) ! { dg-error "enclosing parallel" }
+ i = 1 ! { dg-error "not specified in" }
+!$omp do
+ do i = 1, 10
+ a(i, 1) = i + 1
+ end do
+!$omp end parallel
+!$omp parallel default (none) shared (a) ! { dg-error "enclosing parallel" }
+ i = 1 ! { dg-error "not specified in" }
+!$omp parallel do default (none) shared (a)
+ do i = 1, 10
+ a(i, 1) = i + 1
+ end do
+!$omp end parallel
+!$omp parallel default (none) shared (a)
+ i = 1
+!$omp parallel default (none) shared (a, i)
+ i = 2
+!$omp parallel default (none) shared (a)
+ do i = 1, 10
+ a(i, 1) = i
+ end do
+!$omp end parallel
+ i = 3
+!$omp end parallel
+ i = 4
+!$omp end parallel
+end
--- /dev/null
+! { dg-do compile }
+
+interface
+ subroutine foo
+ end subroutine
+ function bar ()
+ integer :: bar
+ end function bar
+ elemental function baz ()
+ integer :: baz
+ end function baz
+end interface
+
+ integer :: i, j
+ real :: a, b (10), c
+ a = 0.5
+ b = 0.25
+!$omp parallel workshare
+ a = sin (a)
+ b = sin (b)
+ forall (i = 1:10) b(i) = cos (b(i)) - 0.5
+ j = baz ()
+!$omp parallel if (bar () .gt. 2) &
+!$omp & num_threads (bar () + 1)
+ i = bar ()
+!$omp end parallel
+!$omp parallel do schedule (static, bar () + 4)
+ do j = 1, 10
+ i = bar ()
+ end do
+!$omp end parallel do
+!$omp end parallel workshare
+!$omp parallel workshare
+ call foo ! { dg-error "CALL statement" }
+ i = bar () ! { dg-error "non-ELEMENTAL" }
+!$omp critical
+ i = bar () ! { dg-error "non-ELEMENTAL" }
+!$omp end critical
+!$omp atomic
+ j = j + bar () ! { dg-error "non-ELEMENTAL" }
+!$omp end parallel workshare
+end
+2006-02-13 Jakub Jelinek <jakub@redhat.com>
+
+ * testsuite/libgomp.fortran/vla7.f90: Add -w to options.
+ Remove tests for returning assumed character length arrays.
+
2006-02-12 Roger Sayle <roger@eyesopen.com>
John David Anglin <dave@hiauly1.hia.nrc.ca>
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE WORK(N)
+ INTEGER N
+ END SUBROUTINE WORK
+ SUBROUTINE SUB3(N)
+ INTEGER N
+ CALL WORK(N)
+!$OMP BARRIER
+ CALL WORK(N)
+ END SUBROUTINE SUB3
+ SUBROUTINE SUB2(K)
+ INTEGER K
+!$OMP PARALLEL SHARED(K)
+ CALL SUB3(K)
+!$OMP END PARALLEL
+ END SUBROUTINE SUB2
+ SUBROUTINE SUB1(N)
+ INTEGER N
+ INTEGER I
+!$OMP PARALLEL PRIVATE(I) SHARED(N)
+!$OMP DO
+ DO I = 1, N
+ CALL SUB2(I)
+ END DO
+!$OMP END PARALLEL
+ END SUBROUTINE SUB1
+ PROGRAM A15
+ CALL SUB1(2)
+ CALL SUB2(2)
+ CALL SUB3(2)
+ END PROGRAM A15
--- /dev/null
+! { dg-do run }
+ REAL FUNCTION WORK1(I)
+ INTEGER I
+ WORK1 = 1.0 * I
+ RETURN
+ END FUNCTION WORK1
+
+ REAL FUNCTION WORK2(I)
+ INTEGER I
+ WORK2 = 2.0 * I
+ RETURN
+ END FUNCTION WORK2
+
+ SUBROUTINE SUBA16(X, Y, INDEX, N)
+ REAL X(*), Y(*)
+ INTEGER INDEX(*), N
+ INTEGER I
+!$OMP PARALLEL DO SHARED(X, Y, INDEX, N)
+ DO I=1,N
+!$OMP ATOMIC
+ X(INDEX(I)) = X(INDEX(I)) + WORK1(I)
+ Y(I) = Y(I) + WORK2(I)
+ ENDDO
+ END SUBROUTINE SUBA16
+
+ PROGRAM A16
+ REAL X(1000), Y(10000)
+ INTEGER INDEX(10000)
+ INTEGER I
+ DO I=1,10000
+ INDEX(I) = MOD(I, 1000) + 1
+ Y(I) = 0.0
+ ENDDO
+ DO I = 1,1000
+ X(I) = 0.0
+ ENDDO
+ CALL SUBA16(X, Y, INDEX, 10000)
+ DO I = 1,10
+ PRINT *, "X(", I, ") = ", X(I), ", Y(", I, ") = ", Y(I)
+ ENDDO
+ END PROGRAM A16
--- /dev/null
+! { dg-do run }
+! { dg-options "-ffixed-form" }
+ REAL FUNCTION FN1(I)
+ INTEGER I
+ FN1 = I * 2.0
+ RETURN
+ END FUNCTION FN1
+
+ REAL FUNCTION FN2(A, B)
+ REAL A, B
+ FN2 = A + B
+ RETURN
+ END FUNCTION FN2
+
+ PROGRAM A18
+ INCLUDE "omp_lib.h" ! or USE OMP_LIB
+ INTEGER ISYNC(256)
+ REAL WORK(256)
+ REAL RESULT(256)
+ INTEGER IAM, NEIGHBOR
+!$OMP PARALLEL PRIVATE(IAM, NEIGHBOR) SHARED(WORK, ISYNC) NUM_THREADS(4)
+ IAM = OMP_GET_THREAD_NUM() + 1
+ ISYNC(IAM) = 0
+!$OMP BARRIER
+! Do computation into my portion of work array
+ WORK(IAM) = FN1(IAM)
+! Announce that I am done with my work.
+! The first flush ensures that my work is made visible before
+! synch. The second flush ensures that synch is made visible.
+!$OMP FLUSH(WORK,ISYNC)
+ ISYNC(IAM) = 1
+!$OMP FLUSH(ISYNC)
+
+! Wait until neighbor is done. The first flush ensures that
+! synch is read from memory, rather than from the temporary
+! view of memory. The second flush ensures that work is read
+! from memory, and is done so after the while loop exits.
+ IF (IAM .EQ. 1) THEN
+ NEIGHBOR = OMP_GET_NUM_THREADS()
+ ELSE
+ NEIGHBOR = IAM - 1
+ ENDIF
+ DO WHILE (ISYNC(NEIGHBOR) .EQ. 0)
+!$OMP FLUSH(ISYNC)
+ END DO
+!$OMP FLUSH(WORK, ISYNC)
+ RESULT(IAM) = FN2(WORK(NEIGHBOR), WORK(IAM))
+!$OMP END PARALLEL
+ DO I=1,4
+ IF (I .EQ. 1) THEN
+ NEIGHBOR = 4
+ ELSE
+ NEIGHBOR = I - 1
+ ENDIF
+ IF (RESULT(I) .NE. I * 2 + NEIGHBOR * 2) THEN
+ CALL ABORT
+ ENDIF
+ ENDDO
+ END PROGRAM A18
--- /dev/null
+! { dg-do run }
+ SUBROUTINE F1(Q)
+ COMMON /DATA/ P, X
+ INTEGER, TARGET :: X
+ INTEGER, POINTER :: P
+ INTEGER Q
+ Q=1
+!$OMP FLUSH
+ ! X, P and Q are flushed
+ ! because they are shared and accessible
+ END SUBROUTINE F1
+ SUBROUTINE F2(Q)
+ COMMON /DATA/ P, X
+ INTEGER, TARGET :: X
+ INTEGER, POINTER :: P
+ INTEGER Q
+!$OMP BARRIER
+ Q=2
+!$OMP BARRIER
+ ! a barrier implies a flush
+ ! X, P and Q are flushed
+ ! because they are shared and accessible
+ END SUBROUTINE F2
+
+ INTEGER FUNCTION G(N)
+ COMMON /DATA/ P, X
+ INTEGER, TARGET :: X
+ INTEGER, POINTER :: P
+ INTEGER N
+ INTEGER I, J, SUM
+ I=1
+ SUM = 0
+ P=1
+!$OMP PARALLEL REDUCTION(+: SUM) NUM_THREADS(2)
+ CALL F1(J)
+ ! I, N and SUM were not flushed
+ ! because they were not accessible in F1
+ ! J was flushed because it was accessible
+ SUM = SUM + J
+ CALL F2(J)
+ ! I, N, and SUM were not flushed
+ ! because they were not accessible in f2
+ ! J was flushed because it was accessible
+ SUM = SUM + I + J + P + N
+!$OMP END PARALLEL
+ G = SUM
+ END FUNCTION G
+
+ PROGRAM A19
+ COMMON /DATA/ P, X
+ INTEGER, TARGET :: X
+ INTEGER, POINTER :: P
+ INTEGER RESULT, G
+ P => X
+ RESULT = G(10)
+ PRINT *, RESULT
+ IF (RESULT .NE. 30) THEN
+ CALL ABORT
+ ENDIF
+ END PROGRAM A19
--- /dev/null
+! { dg-do run }
+PROGRAM A2
+ INCLUDE "omp_lib.h" ! or USE OMP_LIB
+ INTEGER X
+ X=2
+!$OMP PARALLEL NUM_THREADS(2) SHARED(X)
+ IF (OMP_GET_THREAD_NUM() .EQ. 0) THEN
+ X=5
+ ELSE
+ ! PRINT 1: The following read of x has a race
+ PRINT *,"1: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X
+ ENDIF
+!$OMP BARRIER
+ IF (OMP_GET_THREAD_NUM() .EQ. 0) THEN
+ ! PRINT 2
+ PRINT *,"2: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X
+ ELSE
+ ! PRINT 3
+ PRINT *,"3: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X
+ ENDIF
+!$OMP END PARALLEL
+END PROGRAM A2
--- /dev/null
+! { dg-do compile }
+ SUBROUTINE WORK(K)
+ INTEGER k
+!$OMP ORDERED
+ WRITE(*,*) K
+!$OMP END ORDERED
+ END SUBROUTINE WORK
+ SUBROUTINE SUBA21(LB, UB, STRIDE)
+ INTEGER LB, UB, STRIDE
+ INTEGER I
+!$OMP PARALLEL DO ORDERED SCHEDULE(DYNAMIC)
+ DO I=LB,UB,STRIDE
+ CALL WORK(I)
+ END DO
+!$OMP END PARALLEL DO
+ END SUBROUTINE SUBA21
+ PROGRAM A21
+ CALL SUBA21(1,100,5)
+ END PROGRAM A21
--- /dev/null
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+
+ PROGRAM A22_7_GOOD
+ INTEGER, ALLOCATABLE, SAVE :: A(:)
+ INTEGER, POINTER, SAVE :: PTR
+ INTEGER, SAVE :: I
+ INTEGER, TARGET :: TARG
+ LOGICAL :: FIRSTIN = .TRUE.
+!$OMP THREADPRIVATE(A, I, PTR)
+ ALLOCATE (A(3))
+ A = (/1,2,3/)
+ PTR => TARG
+ I=5
+!$OMP PARALLEL COPYIN(I, PTR)
+!$OMP CRITICAL
+ IF (FIRSTIN) THEN
+ TARG = 4 ! Update target of ptr
+ I = I + 10
+ IF (ALLOCATED(A)) A = A + 10
+ FIRSTIN = .FALSE.
+ END IF
+ IF (ALLOCATED(A)) THEN
+ PRINT *, "a = ", A
+ ELSE
+ PRINT *, "A is not allocated"
+ END IF
+ PRINT *, "ptr = ", PTR
+ PRINT *, "i = ", I
+ PRINT *
+!$OMP END CRITICAL
+!$OMP END PARALLEL
+ END PROGRAM A22_7_GOOD
--- /dev/null
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+ MODULE A22_MODULE8
+ REAL, POINTER :: WORK(:)
+ SAVE WORK
+!$OMP THREADPRIVATE(WORK)
+ END MODULE A22_MODULE8
+ SUBROUTINE SUB1(N)
+ USE A22_MODULE8
+!$OMP PARALLEL PRIVATE(THE_SUM)
+ ALLOCATE(WORK(N))
+ CALL SUB2(THE_SUM)
+ WRITE(*,*)THE_SUM
+!$OMP END PARALLEL
+ END SUBROUTINE SUB1
+ SUBROUTINE SUB2(THE_SUM)
+ USE A22_MODULE8
+ WORK(:) = 10
+ THE_SUM=SUM(WORK)
+ END SUBROUTINE SUB2
+ PROGRAM A22_8_GOOD
+ N = 10
+ CALL SUB1(N)
+ END PROGRAM A22_8_GOOD
+
--- /dev/null
+! { dg-do run }
+ PROGRAM A26
+ INTEGER I, J
+ I=1
+ J=2
+!$OMP PARALLEL PRIVATE(I) FIRSTPRIVATE(J)
+ I=3
+ J=J+2
+!$OMP END PARALLEL
+ PRINT *, I, J ! I and J are undefined
+ END PROGRAM A26
--- /dev/null
+! { dg-do run }
+
+ SUBROUTINE SUB()
+ COMMON /BLOCK/ X
+ PRINT *,X ! X is undefined
+ END SUBROUTINE SUB
+ PROGRAM A28_1
+ COMMON /BLOCK/ X
+ X = 1.0
+!$OMP PARALLEL PRIVATE (X)
+ X = 2.0
+ CALL SUB()
+!$OMP END PARALLEL
+ END PROGRAM A28_1
--- /dev/null
+! { dg-do run }
+
+ PROGRAM A28_2
+ COMMON /BLOCK2/ X
+ X = 1.0
+!$OMP PARALLEL PRIVATE (X)
+ X = 2.0
+ CALL SUB()
+!$OMP END PARALLEL
+ CONTAINS
+ SUBROUTINE SUB()
+ COMMON /BLOCK2/ Y
+ PRINT *,X ! X is undefined
+ PRINT *,Y ! Y is undefined
+ END SUBROUTINE SUB
+ END PROGRAM A28_2
--- /dev/null
+! { dg-do run }
+
+ PROGRAM A28_3
+ EQUIVALENCE (X,Y)
+ X = 1.0
+!$OMP PARALLEL PRIVATE(X)
+ PRINT *,Y ! Y is undefined
+ Y = 10
+ PRINT *,X ! X is undefined
+!$OMP END PARALLEL
+ END PROGRAM A28_3
--- /dev/null
+! { dg-do run }
+
+ PROGRAM A28_4
+ INTEGER I, J
+ INTEGER A(100), B(100)
+ EQUIVALENCE (A(51), B(1))
+!$OMP PARALLEL DO DEFAULT(PRIVATE) PRIVATE(I,J) LASTPRIVATE(A)
+ DO I=1,100
+ DO J=1,100
+ B(J) = J - 1
+ ENDDO
+ DO J=1,100
+ A(J) = J ! B becomes undefined at this point
+ ENDDO
+ DO J=1,50
+ B(J) = B(J) + 1 ! B is undefined
+ ! A becomes undefined at this point
+ ENDDO
+ ENDDO
+!$OMP END PARALLEL DO ! The LASTPRIVATE write for A has
+ ! undefined results
+ PRINT *, B ! B is undefined since the LASTPRIVATE
+ ! write of A was not defined
+ END PROGRAM A28_4
--- /dev/null
+! { dg-do compile }
+
+ SUBROUTINE SUB1(X)
+ DIMENSION X(10)
+ ! This use of X does not conform to the
+ ! specification. It would be legal Fortran 90,
+ ! but the OpenMP private directive allows the
+ ! compiler to break the sequence association that
+ ! A had with the rest of the common block.
+ FORALL (I = 1:10) X(I) = I
+ END SUBROUTINE SUB1
+ PROGRAM A28_5
+ COMMON /BLOCK5/ A
+ DIMENSION B(10)
+ EQUIVALENCE (A,B(1))
+ ! the common block has to be at least 10 words
+ A=0
+!$OMP PARALLEL PRIVATE(/BLOCK5/)
+ ! Without the private clause,
+ ! we would be passing a member of a sequence
+ ! that is at least ten elements long.
+ ! With the private clause, A may no longer be
+ ! sequence-associated.
+ CALL SUB1(A)
+!$OMP MASTER
+ PRINT *, A
+!$OMP END MASTER
+!$OMP END PARALLEL
+ END PROGRAM A28_5
--- /dev/null
+! { dg-do run }
+! { dg-options "-ffixed-form" }
+ PROGRAM A3
+!234567890
+!$ PRINT *, "Compiled by an OpenMP-compliant implementation."
+ END PROGRAM A3
--- /dev/null
+! { dg-do run }
+ MODULE M
+ INTRINSIC MAX
+ END MODULE M
+ PROGRAM A31_4
+ USE M, REN => MAX
+ N=0
+!$OMP PARALLEL DO REDUCTION(REN: N) ! still does MAX
+ DO I = 1, 100
+ N = MAX(N,I)
+ END DO
+ END PROGRAM A31_4
--- /dev/null
+! { dg-do run }
+ MODULE MOD
+ INTRINSIC MAX, MIN
+ END MODULE MOD
+ PROGRAM A31_5
+ USE MOD, MIN=>MAX, MAX=>MIN
+ REAL :: R
+ R = -HUGE(0.0)
+ !$OMP PARALLEL DO REDUCTION(MIN: R) ! still does MAX
+ DO I = 1, 1000
+ R = MIN(R, SIN(REAL(I)))
+ END DO
+ PRINT *, R
+ END PROGRAM A31_5
--- /dev/null
+! { dg-do compile }
+
+ FUNCTION NEW_LOCK()
+ USE OMP_LIB ! or INCLUDE "omp_lib.h"
+ INTEGER(OMP_LOCK_KIND), POINTER :: NEW_LOCK
+!$OMP SINGLE
+ ALLOCATE(NEW_LOCK)
+ CALL OMP_INIT_LOCK(NEW_LOCK)
+!$OMP END SINGLE COPYPRIVATE(NEW_LOCK)
+ END FUNCTION NEW_LOCK
--- /dev/null
+! { dg-do compile }
+
+ FUNCTION NEW_LOCKS()
+ USE OMP_LIB ! or INCLUDE "omp_lib.h"
+ INTEGER(OMP_LOCK_KIND), DIMENSION(1000) :: NEW_LOCKS
+ INTEGER I
+!$OMP PARALLEL DO PRIVATE(I)
+ DO I=1,1000
+ CALL OMP_INIT_LOCK(NEW_LOCKS(I))
+ END DO
+!$OMP END PARALLEL DO
+ END FUNCTION NEW_LOCKS
--- /dev/null
+! { dg-do run }
+
+ SUBROUTINE SKIP(ID)
+ END SUBROUTINE SKIP
+ SUBROUTINE WORK(ID)
+ END SUBROUTINE WORK
+ PROGRAM A39
+ INCLUDE "omp_lib.h" ! or USE OMP_LIB
+ INTEGER(OMP_LOCK_KIND) LCK
+ INTEGER ID
+ CALL OMP_INIT_LOCK(LCK)
+!$OMP PARALLEL SHARED(LCK) PRIVATE(ID)
+ ID = OMP_GET_THREAD_NUM()
+ CALL OMP_SET_LOCK(LCK)
+ PRINT *, "My thread id is ", ID
+ CALL OMP_UNSET_LOCK(LCK)
+ DO WHILE (.NOT. OMP_TEST_LOCK(LCK))
+ CALL SKIP(ID) ! We do not yet have the lock
+ ! so we must do something else
+ END DO
+ CALL WORK(ID) ! We now have the lock
+ ! and can do the work
+ CALL OMP_UNSET_LOCK( LCK )
+!$OMP END PARALLEL
+ CALL OMP_DESTROY_LOCK( LCK )
+ END PROGRAM A39
--- /dev/null
+! { dg-do run }
+ SUBROUTINE SUBDOMAIN(X, ISTART, IPOINTS)
+ INTEGER ISTART, IPOINTS
+ REAL X(*)
+ INTEGER I
+ DO 100 I=1,IPOINTS
+ X(ISTART+I) = 123.456
+ 100 CONTINUE
+ END SUBROUTINE SUBDOMAIN
+ SUBROUTINE SUB(X, NPOINTS)
+ INCLUDE "omp_lib.h" ! or USE OMP_LIB
+ REAL X(*)
+ INTEGER NPOINTS
+ INTEGER IAM, NT, IPOINTS, ISTART
+!$OMP PARALLEL DEFAULT(PRIVATE) SHARED(X,NPOINTS)
+ IAM = OMP_GET_THREAD_NUM()
+ NT = OMP_GET_NUM_THREADS()
+ IPOINTS = NPOINTS/NT
+ ISTART = IAM * IPOINTS
+ IF (IAM .EQ. NT-1) THEN
+ IPOINTS = NPOINTS - ISTART
+ ENDIF
+ CALL SUBDOMAIN(X,ISTART,IPOINTS)
+!$OMP END PARALLEL
+ END SUBROUTINE SUB
+ PROGRAM A4
+ REAL ARRAY(10000)
+ CALL SUB(ARRAY, 10000)
+ END PROGRAM A4
--- /dev/null
+! { dg-do compile }
+! { dg-options "-ffixed-form" }
+ MODULE DATA
+ USE OMP_LIB, ONLY: OMP_NEST_LOCK_KIND
+ TYPE LOCKED_PAIR
+ INTEGER A
+ INTEGER B
+ INTEGER (OMP_NEST_LOCK_KIND) LCK
+ END TYPE
+ END MODULE DATA
+ SUBROUTINE INCR_A(P, A)
+ ! called only from INCR_PAIR, no need to lock
+ USE DATA
+ TYPE(LOCKED_PAIR) :: P
+ INTEGER A
+ P%A = P%A + A
+ END SUBROUTINE INCR_A
+ SUBROUTINE INCR_B(P, B)
+ ! called from both INCR_PAIR and elsewhere,
+ ! so we need a nestable lock
+ USE OMP_LIB ! or INCLUDE "omp_lib.h"
+ USE DATA
+ TYPE(LOCKED_PAIR) :: P
+ INTEGER B
+ CALL OMP_SET_NEST_LOCK(P%LCK)
+ P%B = P%B + B
+ CALL OMP_UNSET_NEST_LOCK(P%LCK)
+ END SUBROUTINE INCR_B
+ SUBROUTINE INCR_PAIR(P, A, B)
+ USE OMP_LIB ! or INCLUDE "omp_lib.h"
+ USE DATA
+ TYPE(LOCKED_PAIR) :: P
+ INTEGER A
+ INTEGER B
+ CALL OMP_SET_NEST_LOCK(P%LCK)
+ CALL INCR_A(P, A)
+ CALL INCR_B(P, B)
+ CALL OMP_UNSET_NEST_LOCK(P%LCK)
+ END SUBROUTINE INCR_PAIR
+ SUBROUTINE A40(P)
+ USE OMP_LIB ! or INCLUDE "omp_lib.h"
+ USE DATA
+ TYPE(LOCKED_PAIR) :: P
+ INTEGER WORK1, WORK2, WORK3
+ EXTERNAL WORK1, WORK2, WORK3
+!$OMP PARALLEL SECTIONS
+!$OMP SECTION
+ CALL INCR_PAIR(P, WORK1(), WORK2())
+!$OMP SECTION
+ CALL INCR_B(P, WORK3())
+!$OMP END PARALLEL SECTIONS
+ END SUBROUTINE A40
--- /dev/null
+! { dg-do run }
+ PROGRAM A5
+ INCLUDE "omp_lib.h" ! or USE OMP_LIB
+ CALL OMP_SET_DYNAMIC(.TRUE.)
+!$OMP PARALLEL NUM_THREADS(10)
+ ! do work here
+!$OMP END PARALLEL
+ END PROGRAM A5
--- /dev/null
+! { dg-do run }
+ SUBROUTINE WORK1()
+ END SUBROUTINE WORK1
+ SUBROUTINE WORK2()
+ END SUBROUTINE WORK2
+ PROGRAM A10
+!$OMP PARALLEL
+!$OMP SINGLE
+ print *, "Beginning work1."
+!$OMP END SINGLE
+ CALL WORK1()
+!$OMP SINGLE
+ print *, "Finishing work1."
+!$OMP END SINGLE
+!$OMP SINGLE
+ print *, "Finished work1 and beginning work2."
+!$OMP END SINGLE NOWAIT
+ CALL WORK2()
+!$OMP END PARALLEL
+ END PROGRAM A10
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+
+ character (len = 8) :: h, i
+ character (len = 4) :: j, k
+ h = '01234567'
+ i = 'ABCDEFGH'
+ j = 'IJKL'
+ k = 'MN'
+ call test (h, j)
+contains
+ subroutine test (p, q)
+ character (len = 8) :: p
+ character (len = 4) :: q, r
+ character (len = 16) :: f
+ character (len = 32) :: g
+ integer, dimension (18) :: s
+ logical :: l
+ integer :: m
+ f = 'test16'
+ g = 'abcdefghijklmnopqrstuvwxyz'
+ r = ''
+ l = .false.
+ s = -6
+!$omp parallel firstprivate (f, p, s) private (r, m) reduction (.or.:l) &
+!$omp & num_threads (4)
+ m = omp_get_thread_num ()
+ if (any (s .ne. -6)) l = .true.
+ l = l .or. f .ne. 'test16' .or. p .ne. '01234567'
+ l = l .or. g .ne. 'abcdefghijklmnopqrstuvwxyz'
+ l = l .or. i .ne. 'ABCDEFGH' .or. q .ne. 'IJKL'
+ l = l .or. k .ne. 'MN'
+!$omp barrier
+ if (m .eq. 0) then
+ f = 'ffffffff0'
+ g = 'xyz'
+ i = '123'
+ k = '9876'
+ p = '_abc'
+ q = '_def'
+ r = '1_23'
+ else if (m .eq. 1) then
+ f = '__'
+ p = 'xxx'
+ r = '7575'
+ else if (m .eq. 2) then
+ f = 'ZZ'
+ p = 'm2'
+ r = 'M2'
+ else if (m .eq. 3) then
+ f = 'YY'
+ p = 'm3'
+ r = 'M3'
+ end if
+ s = m
+!$omp barrier
+ l = l .or. g .ne. 'xyz' .or. i .ne. '123' .or. k .ne. '9876'
+ l = l .or. q .ne. '_def'
+ if (any (s .ne. m)) l = .true.
+ if (m .eq. 0) then
+ l = l .or. f .ne. 'ffffffff0' .or. p .ne. '_abc' .or. r .ne. '1_23'
+ else if (m .eq. 1) then
+ l = l .or. f .ne. '__' .or. p .ne. 'xxx' .or. r .ne. '7575'
+ else if (m .eq. 2) then
+ l = l .or. f .ne. 'ZZ' .or. p .ne. 'm2' .or. r .ne. 'M2'
+ else if (m .eq. 3) then
+ l = l .or. f .ne. 'YY' .or. p .ne. 'm3' .or. r .ne. 'M3'
+ end if
+!$omp end parallel
+ if (l) call abort
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+
+ character (len = 8) :: h
+ character (len = 9) :: i
+ h = '01234567'
+ i = 'ABCDEFGHI'
+ call test (h, i, 9)
+contains
+ subroutine test (p, q, n)
+ character (len = *) :: p
+ character (len = n) :: q
+ character (len = n) :: r
+ character (len = n) :: t
+ character (len = n) :: u
+ integer, dimension (n + 4) :: s
+ logical :: l
+ integer :: m
+ r = ''
+ if (n .gt. 8) r = 'jklmnopqr'
+ do m = 1, n + 4
+ s(m) = m
+ end do
+ u = 'abc'
+ l = .false.
+!$omp parallel firstprivate (p, q, r) private (t, m) reduction (.or.:l) &
+!$omp & num_threads (2)
+ do m = 1, 13
+ if (s(m) .ne. m) l = .true.
+ end do
+ m = omp_get_thread_num ()
+ l = l .or. p .ne. '01234567' .or. q .ne. 'ABCDEFGHI'
+ l = l .or. r .ne. 'jklmnopqr' .or. u .ne. 'abc'
+!$omp barrier
+ if (m .eq. 0) then
+ p = 'A'
+ q = 'B'
+ r = 'C'
+ t = '123'
+ u = '987654321'
+ else if (m .eq. 1) then
+ p = 'D'
+ q = 'E'
+ r = 'F'
+ t = '456'
+ s = m
+ end if
+!$omp barrier
+ l = l .or. u .ne. '987654321'
+ if (any (s .ne. 1)) l = .true.
+ if (m .eq. 0) then
+ l = l .or. p .ne. 'A' .or. q .ne. 'B' .or. r .ne. 'C'
+ l = l .or. t .ne. '123'
+ else
+ l = l .or. p .ne. 'D' .or. q .ne. 'E' .or. r .ne. 'F'
+ l = l .or. t .ne. '456'
+ end if
+!$omp end parallel
+ if (l) call abort
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fopenmp -fcray-pointer" }
+
+ use omp_lib
+ integer :: a, b, c, p
+ logical :: l
+ pointer (ip, p)
+ a = 1
+ b = 2
+ c = 3
+ l = .false.
+ ip = loc (a)
+
+!$omp parallel num_threads (2) reduction (.or.:l)
+ l = p .ne. 1
+!$omp barrier
+!$omp master
+ ip = loc (b)
+!$omp end master
+!$omp barrier
+ l = l .or. p .ne. 2
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1 .or. omp_get_num_threads () .lt. 2) &
+ ip = loc (c)
+!$omp barrier
+ l = l .or. p .ne. 3
+!$omp end parallel
+
+ if (l) call abort
+
+ l = .false.
+!$omp parallel num_threads (2) reduction (.or.:l) default (private)
+ ip = loc (a)
+ a = 3 * omp_get_thread_num () + 4
+ b = a + 1
+ c = a + 2
+ l = p .ne. 3 * omp_get_thread_num () + 4
+ ip = loc (c)
+ l = l .or. p .ne. 3 * omp_get_thread_num () + 6
+ ip = loc (b)
+ l = l .or. p .ne. 3 * omp_get_thread_num () + 5
+!$omp end parallel
+
+ if (l) call abort
+
+end
--- /dev/null
+! { dg-do run }
+
+ integer, dimension (128) :: a, b
+ integer :: i
+ a = -1
+ b = -1
+ do i = 1, 128
+ if (i .ge. 8 .and. i .le. 15) then
+ b(i) = 1 * 256 + i
+ else if (i .ge. 19 .and. i .le. 23) then
+ b(i) = 2 * 256 + i
+ else if (i .ge. 28 .and. i .le. 38) then
+ if (iand (i, 1) .eq. 0) b(i) = 3 * 256 + i
+ else if (i .ge. 59 .and. i .le. 79) then
+ if (iand (i - 59, 3) .eq. 0) b(i) = 4 * 256 + i
+ else if (i .ge. 101 .and. i .le. 125) then
+ if (mod (i - 101, 12) .eq. 0) b(i) = 5 * 256 + i
+ end if
+ end do
+
+!$omp parallel num_threads (4)
+
+!$omp do
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+ end do
+
+!$omp do
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+ end do
+
+!$omp do
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+ end do
+
+!$omp do
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+ end do
+
+!$omp do
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b)) call abort
+ a = -1
+
+!$omp parallel num_threads (4)
+
+!$omp do schedule (static)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+ end do
+
+!$omp do schedule (static, 1)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+ end do
+
+!$omp do schedule (static, 3)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+ end do
+
+!$omp do schedule (static, 6)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+ end do
+
+!$omp do schedule (static, 2)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b)) call abort
+ a = -1
+
+!$omp parallel num_threads (4)
+
+!$omp do schedule (dynamic)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+ end do
+
+!$omp do schedule (dynamic, 4)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+ end do
+
+!$omp do schedule (dynamic, 1)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+ end do
+
+!$omp do schedule (dynamic, 2)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+ end do
+
+!$omp do schedule (dynamic, 3)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b)) call abort
+ a = -1
+
+!$omp parallel num_threads (4)
+
+!$omp do schedule (guided)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+ end do
+
+!$omp do schedule (guided, 4)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+ end do
+
+!$omp do schedule (guided, 1)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+ end do
+
+!$omp do schedule (guided, 2)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+ end do
+
+!$omp do schedule (guided, 3)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b)) call abort
+ a = -1
+
+!$omp parallel num_threads (4)
+
+!$omp do schedule (runtime)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+ end do
+
+!$omp do schedule (runtime)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+ end do
+
+!$omp do schedule (runtime)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+ end do
+
+!$omp do schedule (runtime)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+ end do
+
+!$omp do schedule (runtime)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b)) call abort
+end
--- /dev/null
+! { dg-do run }
+
+ integer, dimension (128) :: a, b
+ integer :: i, j
+ logical :: k
+ a = -1
+ b = -1
+ do i = 1, 128
+ if (i .ge. 8 .and. i .le. 15) then
+ b(i) = 1 * 256 + i
+ else if (i .ge. 19 .and. i .le. 23) then
+ b(i) = 2 * 256 + i
+ else if (i .ge. 28 .and. i .le. 38) then
+ if (iand (i, 1) .eq. 0) b(i) = 3 * 256 + i
+ else if (i .ge. 59 .and. i .le. 79) then
+ if (iand (i - 59, 3) .eq. 0) b(i) = 4 * 256 + i
+ else if (i .ge. 101 .and. i .le. 125) then
+ if (mod (i - 101, 12) .eq. 0) b(i) = 5 * 256 + i
+ end if
+ end do
+
+ k = .false.
+ j = 8
+!$omp parallel num_threads (4)
+
+!$omp do ordered
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 23
+!$omp end single
+
+!$omp do ordered
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 28
+!$omp end single
+
+!$omp do ordered
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 2
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 79
+!$omp end single
+
+!$omp do ordered
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 4
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 125
+!$omp end single
+
+!$omp do ordered
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 12
+!$omp end ordered
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b) .or. k) call abort
+ a = -1
+ k = .false.
+ j = 8
+!$omp parallel num_threads (4)
+
+!$omp do ordered schedule (static)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 23
+!$omp end single
+
+!$omp do ordered schedule (static, 1)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 28
+!$omp end single
+
+!$omp do ordered schedule (static, 3)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 2
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 79
+!$omp end single
+
+!$omp do ordered schedule (static, 6)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 4
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 125
+!$omp end single
+
+!$omp do ordered schedule (static, 2)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 12
+!$omp end ordered
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b) .or. k) call abort
+ a = -1
+ k = .false.
+ j = 8
+!$omp parallel num_threads (4)
+
+!$omp do ordered schedule (dynamic)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 23
+!$omp end single
+
+!$omp do ordered schedule (dynamic, 4)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 28
+!$omp end single
+
+!$omp do ordered schedule (dynamic, 1)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 2
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 79
+!$omp end single
+
+!$omp do ordered schedule (dynamic, 2)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 4
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 125
+!$omp end single
+
+!$omp do ordered schedule (dynamic, 3)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 12
+!$omp end ordered
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b) .or. k) call abort
+ a = -1
+ k = .false.
+ j = 8
+!$omp parallel num_threads (4)
+
+!$omp do ordered schedule (guided)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 23
+!$omp end single
+
+!$omp do ordered schedule (guided, 4)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 28
+!$omp end single
+
+!$omp do ordered schedule (guided, 1)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 2
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 79
+!$omp end single
+
+!$omp do ordered schedule (guided, 2)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 4
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 125
+!$omp end single
+
+!$omp do ordered schedule (guided, 3)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 12
+!$omp end ordered
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b) .or. k) call abort
+ a = -1
+ k = .false.
+ j = 8
+!$omp parallel num_threads (4)
+
+!$omp do ordered schedule (runtime)
+ do i = 8, 15
+ a(i) = 1 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 23
+!$omp end single
+
+!$omp do ordered schedule (runtime)
+ do i = 23, 19, -1
+ a(i) = 2 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 1
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 28
+!$omp end single
+
+!$omp do ordered schedule (runtime)
+ do i = 28, 39, 2
+ a(i) = 3 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j + 2
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 79
+!$omp end single
+
+!$omp do ordered schedule (runtime)
+ do i = 79, 59, -4
+ a(i) = 4 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 4
+!$omp end ordered
+ end do
+
+!$omp single
+ j = 125
+!$omp end single
+
+!$omp do ordered schedule (runtime)
+ do i = 125, 90, -12
+ a(i) = 5 * 256 + i
+!$omp ordered
+ if (i .ne. j) k = .true.
+ j = j - 12
+!$omp end ordered
+ end do
+
+!$omp end parallel
+
+ if (any (a .ne. b) .or. k) call abort
+end
--- /dev/null
+set lang_library_path "../libgfortran/.libs"
+set lang_test_file "${lang_library_path}/libgfortranbegin.a"
+set lang_link_flags "-lgfortranbegin -lgfortran"
+
+load_lib libgomp-dg.exp
+
+# Initialize dg.
+dg-init
+
+if [file exists "${blddir}/${lang_test_file}"] {
+
+ # Gather a list of all tests.
+ set tests [lsort [find $srcdir/$subdir *.\[fF\]{,90,95}]]
+
+ # Main loop.
+ gfortran-dg-runtest $tests ""
+}
+
+# All done.
+dg-finish
--- /dev/null
+* { dg-do run }
+
+ program main
+************************************************************
+* program to solve a finite difference
+* discretization of Helmholtz equation :
+* (d2/dx2)u + (d2/dy2)u - alpha u = f
+* using Jacobi iterative method.
+*
+* Modified: Sanjiv Shah, Kuck and Associates, Inc. (KAI), 1998
+* Author: Joseph Robicheaux, Kuck and Associates, Inc. (KAI), 1998
+*
+* Directives are used in this code to achieve paralleism.
+* All do loops are parallized with default 'static' scheduling.
+*
+* Input : n - grid dimension in x direction
+* m - grid dimension in y direction
+* alpha - Helmholtz constant (always greater than 0.0)
+* tol - error tolerance for iterative solver
+* relax - Successice over relaxation parameter
+* mits - Maximum iterations for iterative solver
+*
+* On output
+* : u(n,m) - Dependent variable (solutions)
+* : f(n,m) - Right hand side function
+*************************************************************
+ implicit none
+
+ integer n,m,mits,mtemp
+ include "omp_lib.h"
+ double precision tol,relax,alpha
+
+ common /idat/ n,m,mits,mtemp
+ common /fdat/tol,alpha,relax
+*
+* Read info
+*
+ write(*,*) "Input n,m - grid dimension in x,y direction "
+ n = 64
+ m = 64
+* read(5,*) n,m
+ write(*,*) n, m
+ write(*,*) "Input alpha - Helmholts constant "
+ alpha = 0.5
+* read(5,*) alpha
+ write(*,*) alpha
+ write(*,*) "Input relax - Successive over-relaxation parameter"
+ relax = 0.9
+* read(5,*) relax
+ write(*,*) relax
+ write(*,*) "Input tol - error tolerance for iterative solver"
+ tol = 1.0E-12
+* read(5,*) tol
+ write(*,*) tol
+ write(*,*) "Input mits - Maximum iterations for solver"
+ mits = 100
+* read(5,*) mits
+ write(*,*) mits
+
+ call omp_set_num_threads (2)
+
+*
+* Calls a driver routine
+*
+ call driver ()
+
+ stop
+ end
+
+ subroutine driver ( )
+*************************************************************
+* Subroutine driver ()
+* This is where the arrays are allocated and initialzed.
+*
+* Working varaibles/arrays
+* dx - grid spacing in x direction
+* dy - grid spacing in y direction
+*************************************************************
+ implicit none
+
+ integer n,m,mits,mtemp
+ double precision tol,relax,alpha
+
+ common /idat/ n,m,mits,mtemp
+ common /fdat/tol,alpha,relax
+
+ double precision u(n,m),f(n,m),dx,dy
+
+* Initialize data
+
+ call initialize (n,m,alpha,dx,dy,u,f)
+
+* Solve Helmholtz equation
+
+ call jacobi (n,m,dx,dy,alpha,relax,u,f,tol,mits)
+
+* Check error between exact solution
+
+ call error_check (n,m,alpha,dx,dy,u,f)
+
+ return
+ end
+
+ subroutine initialize (n,m,alpha,dx,dy,u,f)
+******************************************************
+* Initializes data
+* Assumes exact solution is u(x,y) = (1-x^2)*(1-y^2)
+*
+******************************************************
+ implicit none
+
+ integer n,m
+ double precision u(n,m),f(n,m),dx,dy,alpha
+
+ integer i,j, xx,yy
+ double precision PI
+ parameter (PI=3.1415926)
+
+ dx = 2.0 / (n-1)
+ dy = 2.0 / (m-1)
+
+* Initilize initial condition and RHS
+
+!$omp parallel do private(xx,yy)
+ do j = 1,m
+ do i = 1,n
+ xx = -1.0 + dx * dble(i-1) ! -1 < x < 1
+ yy = -1.0 + dy * dble(j-1) ! -1 < y < 1
+ u(i,j) = 0.0
+ f(i,j) = -alpha *(1.0-xx*xx)*(1.0-yy*yy)
+ & - 2.0*(1.0-xx*xx)-2.0*(1.0-yy*yy)
+ enddo
+ enddo
+!$omp end parallel do
+
+ return
+ end
+
+ subroutine jacobi (n,m,dx,dy,alpha,omega,u,f,tol,maxit)
+******************************************************************
+* Subroutine HelmholtzJ
+* Solves poisson equation on rectangular grid assuming :
+* (1) Uniform discretization in each direction, and
+* (2) Dirichlect boundary conditions
+*
+* Jacobi method is used in this routine
+*
+* Input : n,m Number of grid points in the X/Y directions
+* dx,dy Grid spacing in the X/Y directions
+* alpha Helmholtz eqn. coefficient
+* omega Relaxation factor
+* f(n,m) Right hand side function
+* u(n,m) Dependent variable/Solution
+* tol Tolerance for iterative solver
+* maxit Maximum number of iterations
+*
+* Output : u(n,m) - Solution
+*****************************************************************
+ implicit none
+ integer n,m,maxit
+ double precision dx,dy,f(n,m),u(n,m),alpha, tol,omega
+*
+* Local variables
+*
+ integer i,j,k,k_local
+ double precision error,resid,rsum,ax,ay,b
+ double precision error_local, uold(n,m)
+
+ real ta,tb,tc,td,te,ta1,ta2,tb1,tb2,tc1,tc2,td1,td2
+ real te1,te2
+ real second
+ external second
+*
+* Initialize coefficients
+ ax = 1.0/(dx*dx) ! X-direction coef
+ ay = 1.0/(dy*dy) ! Y-direction coef
+ b = -2.0/(dx*dx)-2.0/(dy*dy) - alpha ! Central coeff
+
+ error = 10.0 * tol
+ k = 1
+
+ do while (k.le.maxit .and. error.gt. tol)
+
+ error = 0.0
+
+* Copy new solution into old
+!$omp parallel
+
+!$omp do
+ do j=1,m
+ do i=1,n
+ uold(i,j) = u(i,j)
+ enddo
+ enddo
+
+* Compute stencil, residual, & update
+
+!$omp do private(resid) reduction(+:error)
+ do j = 2,m-1
+ do i = 2,n-1
+* Evaluate residual
+ resid = (ax*(uold(i-1,j) + uold(i+1,j))
+ & + ay*(uold(i,j-1) + uold(i,j+1))
+ & + b * uold(i,j) - f(i,j))/b
+* Update solution
+ u(i,j) = uold(i,j) - omega * resid
+* Accumulate residual error
+ error = error + resid*resid
+ end do
+ enddo
+!$omp enddo nowait
+
+!$omp end parallel
+
+* Error check
+
+ k = k + 1
+
+ error = sqrt(error)/dble(n*m)
+*
+ enddo ! End iteration loop
+*
+ print *, 'Total Number of Iterations ', k
+ print *, 'Residual ', error
+
+ return
+ end
+
+ subroutine error_check (n,m,alpha,dx,dy,u,f)
+ implicit none
+************************************************************
+* Checks error between numerical and exact solution
+*
+************************************************************
+
+ integer n,m
+ double precision u(n,m),f(n,m),dx,dy,alpha
+
+ integer i,j
+ double precision xx,yy,temp,error
+
+ dx = 2.0 / (n-1)
+ dy = 2.0 / (m-1)
+ error = 0.0
+
+!$omp parallel do private(xx,yy,temp) reduction(+:error)
+ do j = 1,m
+ do i = 1,n
+ xx = -1.0d0 + dx * dble(i-1)
+ yy = -1.0d0 + dy * dble(j-1)
+ temp = u(i,j) - (1.0-xx*xx)*(1.0-yy*yy)
+ error = error + temp*temp
+ enddo
+ enddo
+
+ error = sqrt(error)/dble(n*m)
+
+ print *, 'Solution Error : ',error
+
+ return
+ end
--- /dev/null
+! { dg-do run }
+
+ use omp_lib
+
+ double precision :: d, e
+ logical :: l
+ integer (kind = omp_lock_kind) :: lck
+ integer (kind = omp_nest_lock_kind) :: nlck
+
+ d = omp_get_wtime ()
+
+ call omp_init_lock (lck)
+ call omp_set_lock (lck)
+ if (omp_test_lock (lck)) call abort
+ call omp_unset_lock (lck)
+ if (.not. omp_test_lock (lck)) call abort
+ if (omp_test_lock (lck)) call abort
+ call omp_unset_lock (lck)
+ call omp_destroy_lock (lck)
+
+ call omp_init_nest_lock (nlck)
+ if (omp_test_nest_lock (nlck) .ne. 1) call abort
+ call omp_set_nest_lock (nlck)
+ if (omp_test_nest_lock (nlck) .ne. 3) call abort
+ call omp_unset_nest_lock (nlck)
+ call omp_unset_nest_lock (nlck)
+ if (omp_test_nest_lock (nlck) .ne. 2) call abort
+ call omp_unset_nest_lock (nlck)
+ call omp_unset_nest_lock (nlck)
+ call omp_destroy_nest_lock (nlck)
+
+ call omp_set_dynamic (.true.)
+ if (.not. omp_get_dynamic ()) call abort
+ call omp_set_dynamic (.false.)
+ if (omp_get_dynamic ()) call abort
+
+ call omp_set_nested (.true.)
+ if (.not. omp_get_nested ()) call abort
+ call omp_set_nested (.false.)
+ if (omp_get_nested ()) call abort
+
+ call omp_set_num_threads (5)
+ if (omp_get_num_threads () .ne. 1) call abort
+ if (omp_get_max_threads () .ne. 5) call abort
+ if (omp_get_thread_num () .ne. 0) call abort
+ call omp_set_num_threads (3)
+ if (omp_get_num_threads () .ne. 1) call abort
+ if (omp_get_max_threads () .ne. 3) call abort
+ if (omp_get_thread_num () .ne. 0) call abort
+ l = .false.
+!$omp parallel reduction (.or.:l)
+ l = omp_get_num_threads () .ne. 3
+ l = l .or. (omp_get_thread_num () .lt. 0)
+ l = l .or. (omp_get_thread_num () .ge. 3)
+!$omp master
+ l = l .or. (omp_get_thread_num () .ne. 0)
+!$omp end master
+!$omp end parallel
+ if (l) call abort
+
+ if (omp_get_num_procs () .le. 0) call abort
+ if (omp_in_parallel ()) call abort
+!$omp parallel reduction (.or.:l)
+ l = .not. omp_in_parallel ()
+!$omp end parallel
+!$omp parallel reduction (.or.:l) if (.true.)
+ l = .not. omp_in_parallel ()
+!$omp end parallel
+
+ e = omp_get_wtime ()
+ if (d .gt. e) call abort
+ d = omp_get_wtick ()
+ ! Negative precision is definitely wrong,
+ ! bigger than 1s clock resolution is also strange
+ if (d .le. 0 .or. d .gt. 1.) call abort
+end
--- /dev/null
+C { dg-do run }
+
+ USE OMP_LIB
+
+ DOUBLE PRECISION :: D, E
+ LOGICAL :: L
+ INTEGER (KIND = OMP_LOCK_KIND) :: LCK
+ INTEGER (KIND = OMP_NEST_LOCK_KIND) :: NLCK
+
+ D = OMP_GET_WTIME ()
+
+ CALL OMP_INIT_LOCK (LCK)
+ CALL OMP_SET_LOCK (LCK)
+ IF (OMP_TEST_LOCK (LCK)) CALL ABORT
+ CALL OMP_UNSET_LOCK (LCK)
+ IF (.NOT. OMP_TEST_LOCK (LCK)) CALL ABORT
+ IF (OMP_TEST_LOCK (LCK)) CALL ABORT
+ CALL OMP_UNSET_LOCK (LCK)
+ CALL OMP_DESTROY_LOCK (LCK)
+
+ CALL OMP_INIT_NEST_LOCK (NLCK)
+ IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 1) CALL ABORT
+ CALL OMP_SET_NEST_LOCK (NLCK)
+ IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 3) CALL ABORT
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 2) CALL ABORT
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ CALL OMP_DESTROY_NEST_LOCK (NLCK)
+
+ CALL OMP_SET_DYNAMIC (.TRUE.)
+ IF (.NOT. OMP_GET_DYNAMIC ()) CALL ABORT
+ CALL OMP_SET_DYNAMIC (.FALSE.)
+ IF (OMP_GET_DYNAMIC ()) CALL ABORT
+
+ CALL OMP_SET_NESTED (.TRUE.)
+ IF (.NOT. OMP_GET_NESTED ()) CALL ABORT
+ CALL OMP_SET_NESTED (.FALSE.)
+ IF (OMP_GET_NESTED ()) CALL ABORT
+
+ CALL OMP_SET_NUM_THREADS (5)
+ IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
+ IF (OMP_GET_MAX_THREADS () .NE. 5) CALL ABORT
+ IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
+ CALL OMP_SET_NUM_THREADS (3)
+ IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
+ IF (OMP_GET_MAX_THREADS () .NE. 3) CALL ABORT
+ IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
+ L = .FALSE.
+C$OMP PARALLEL REDUCTION (.OR.:L)
+ L = OMP_GET_NUM_THREADS () .NE. 3
+ L = L .OR. (OMP_GET_THREAD_NUM () .LT. 0)
+ L = L .OR. (OMP_GET_THREAD_NUM () .GE. 3)
+C$OMP MASTER
+ L = L .OR. (OMP_GET_THREAD_NUM () .NE. 0)
+C$OMP END MASTER
+C$OMP END PARALLEL
+ IF (L) CALL ABORT
+
+ IF (OMP_GET_NUM_PROCS () .LE. 0) CALL ABORT
+ IF (OMP_IN_PARALLEL ()) CALL ABORT
+C$OMP PARALLEL REDUCTION (.OR.:L)
+ L = .NOT. OMP_IN_PARALLEL ()
+C$OMP END PARALLEL
+C$OMP PARALLEL REDUCTION (.OR.:L) IF (.TRUE.)
+ L = .NOT. OMP_IN_PARALLEL ()
+C$OMP END PARALLEL
+
+ E = OMP_GET_WTIME ()
+ IF (D .GT. E) CALL ABORT
+ D = OMP_GET_WTICK ()
+C Negative precision is definitely wrong,
+C bigger than 1s clock resolution is also strange
+ IF (D .LE. 0 .OR. D .GT. 1.) CALL ABORT
+ END
--- /dev/null
+C { dg-do run }
+
+ INCLUDE "omp_lib.h"
+
+ DOUBLE PRECISION :: D, E
+ LOGICAL :: L
+ INTEGER (KIND = OMP_LOCK_KIND) :: LCK
+ INTEGER (KIND = OMP_NEST_LOCK_KIND) :: NLCK
+
+ D = OMP_GET_WTIME ()
+
+ CALL OMP_INIT_LOCK (LCK)
+ CALL OMP_SET_LOCK (LCK)
+ IF (OMP_TEST_LOCK (LCK)) CALL ABORT
+ CALL OMP_UNSET_LOCK (LCK)
+ IF (.NOT. OMP_TEST_LOCK (LCK)) CALL ABORT
+ IF (OMP_TEST_LOCK (LCK)) CALL ABORT
+ CALL OMP_UNSET_LOCK (LCK)
+ CALL OMP_DESTROY_LOCK (LCK)
+
+ CALL OMP_INIT_NEST_LOCK (NLCK)
+ IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 1) CALL ABORT
+ CALL OMP_SET_NEST_LOCK (NLCK)
+ IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 3) CALL ABORT
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 2) CALL ABORT
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ CALL OMP_UNSET_NEST_LOCK (NLCK)
+ CALL OMP_DESTROY_NEST_LOCK (NLCK)
+
+ CALL OMP_SET_DYNAMIC (.TRUE.)
+ IF (.NOT. OMP_GET_DYNAMIC ()) CALL ABORT
+ CALL OMP_SET_DYNAMIC (.FALSE.)
+ IF (OMP_GET_DYNAMIC ()) CALL ABORT
+
+ CALL OMP_SET_NESTED (.TRUE.)
+ IF (.NOT. OMP_GET_NESTED ()) CALL ABORT
+ CALL OMP_SET_NESTED (.FALSE.)
+ IF (OMP_GET_NESTED ()) CALL ABORT
+
+ CALL OMP_SET_NUM_THREADS (5)
+ IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
+ IF (OMP_GET_MAX_THREADS () .NE. 5) CALL ABORT
+ IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
+ CALL OMP_SET_NUM_THREADS (3)
+ IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
+ IF (OMP_GET_MAX_THREADS () .NE. 3) CALL ABORT
+ IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
+ L = .FALSE.
+C$OMP PARALLEL REDUCTION (.OR.:L)
+ L = OMP_GET_NUM_THREADS () .NE. 3
+ L = L .OR. (OMP_GET_THREAD_NUM () .LT. 0)
+ L = L .OR. (OMP_GET_THREAD_NUM () .GE. 3)
+C$OMP MASTER
+ L = L .OR. (OMP_GET_THREAD_NUM () .NE. 0)
+C$OMP END MASTER
+C$OMP END PARALLEL
+ IF (L) CALL ABORT
+
+ IF (OMP_GET_NUM_PROCS () .LE. 0) CALL ABORT
+ IF (OMP_IN_PARALLEL ()) CALL ABORT
+C$OMP PARALLEL REDUCTION (.OR.:L)
+ L = .NOT. OMP_IN_PARALLEL ()
+C$OMP END PARALLEL
+C$OMP PARALLEL REDUCTION (.OR.:L) IF (.TRUE.)
+ L = .NOT. OMP_IN_PARALLEL ()
+C$OMP END PARALLEL
+
+ E = OMP_GET_WTIME ()
+ IF (D .GT. E) CALL ABORT
+ D = OMP_GET_WTICK ()
+C Negative precision is definitely wrong,
+C bigger than 1s clock resolution is also strange
+ IF (D .LE. 0 .OR. D .GT. 1.) CALL ABORT
+ END
--- /dev/null
+! { dg-do run }
+
+ integer :: a, b, c
+ a = 1
+ b = 2
+ c = 3
+ call foo
+ if (a .ne. 7) call abort
+contains
+ subroutine foo
+ use omp_lib
+ logical :: l
+ l = .false.
+!$omp parallel shared (a) private (b) firstprivate (c) &
+!$omp num_threads (2) reduction (.or.:l)
+ if (a .ne. 1 .or. c .ne. 3) l = .true.
+!$omp barrier
+ if (omp_get_thread_num () .eq. 0) then
+ a = 4
+ b = 5
+ c = 6
+ end if
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) then
+ if (a .ne. 4 .or. c .ne. 3) l = .true.
+ a = 7
+ b = 8
+ c = 9
+ else if (omp_get_num_threads () .eq. 1) then
+ a = 7
+ end if
+!$omp barrier
+ if (omp_get_thread_num () .eq. 0) then
+ if (a .ne. 7 .or. b .ne. 5 .or. c .ne. 6) l = .true.
+ end if
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) then
+ if (a .ne. 7 .or. b .ne. 8 .or. c .ne. 9) l = .true.
+ end if
+!$omp end parallel
+ if (l) call abort
+ end subroutine foo
+end
--- /dev/null
+! { dg-do run }
+
+ integer :: i
+ common /c/ i
+ i = -1
+!$omp parallel shared (i) num_threads (4)
+ call test1
+!$omp end parallel
+end
+subroutine test1
+ integer :: vari
+ call test2
+ call test3
+contains
+ subroutine test2
+ use omp_lib
+ integer :: i
+ common /c/ i
+!$omp single
+ i = omp_get_thread_num ()
+ call test4
+!$omp end single copyprivate (vari)
+ end subroutine test2
+ subroutine test3
+ integer :: i
+ common /c/ i
+ if (i .lt. 0 .or. i .ge. 4) call abort
+ if (i + 10 .ne. vari) call abort
+ end subroutine test3
+ subroutine test4
+ use omp_lib
+ vari = omp_get_thread_num () + 10
+ end subroutine test4
+end subroutine test1
--- /dev/null
+! { dg-do run }
+ integer (kind = 4) :: a
+ integer (kind = 2) :: b
+ real :: c, f
+ double precision :: d
+ integer, dimension (10) :: e
+ a = 1
+ b = 2
+ c = 3
+ d = 4
+ e = 5
+ f = 6
+!$omp atomic
+ a = a + 4
+!$omp atomic
+ b = 4 - b
+!$omp atomic
+ c = c * 2
+!$omp atomic
+ d = 2 / d
+ if (a .ne. 5 .or. b .ne. 2 .or. c .ne. 6 .or. d .ne. 0.5) call abort
+ d = 1.2
+!$omp atomic
+ a = a + c + d
+!$omp atomic
+ b = b - (a + c + d)
+ if (a .ne. 12 .or. b .ne. -17) call abort
+!$omp atomic
+ a = c + d + a
+!$omp atomic
+ b = a + c + d - b
+ if (a .ne. 19 .or. b .ne. 43) call abort
+!$omp atomic
+ b = (a + c + d) - b
+ a = 32
+!$omp atomic
+ a = a / 3.4
+ if (a .ne. 9 .or. b .ne. -16) call abort
+end
--- /dev/null
+! { dg-do run }
+ real, dimension (20) :: r
+ integer, dimension (20) :: d
+ integer :: i, j, k, n
+ integer (kind = 2) :: a, b, c
+
+ do 10 i = 1, 20
+ r(i) = i
+10 d(i) = 21 - i
+
+ n = 20
+ call foo (r, d, n)
+
+ if (n .ne. 22) call abort
+ if (any (r .ne. 33)) call abort
+
+ i = 1
+ j = 18
+ k = 23
+!$omp atomic
+ i = min (i, j, k, n)
+ if (i .ne. 1) call abort
+!$omp atomic
+ i = max (j, n, k, i)
+ if (i .ne. 23) call abort
+
+ a = 1
+ b = 18
+ c = 23
+!$omp atomic
+ a = min (a, b, c)
+ if (a .ne. 1) call abort
+!$omp atomic
+ a = max (a, b, c)
+ if (a .ne. 23) call abort
+
+contains
+ function bar (i)
+ real bar
+ integer i
+ bar = 12.0 + i
+ end function bar
+
+ subroutine foo (x, y, n)
+ integer i, y (*), n
+ real x (*)
+ do i = 1, n
+!$omp atomic
+ x(y(i)) = x(y(i)) + bar (i)
+ end do
+!$omp atomic
+ n = n + 2
+ end subroutine foo
+end
--- /dev/null
+C Test conditional compilation in fixed form if -fopenmp
+! { dg-options "-fopenmp" }
+ 10 foo = 2
+ &56
+ if (foo.ne.256) call abort
+ bar = 26
+!$2 0 ba
+c$ +r = 42
+ !$ bar = 62
+!$ bar = bar + 1
+ if (bar.ne.43) call abort
+ baz = bar
+*$ 0baz = 5
+C$ +12! Comment
+c$ !4
+!$ +!Another comment
+*$ &2
+!$ X baz = 0 ! Not valid OpenMP conditional compilation lines
+! $ baz = 1
+c$ 10&baz = 2
+ if (baz.ne.51242) call abort
+ end
--- /dev/null
+c Test conditional compilation in fixed form if -fno-openmp
+! { dg-options "-fno-openmp" }
+ 10 foo = 2
+ &56
+ if (foo.ne.256) call abort
+ bar = 26
+!$2 0 ba
+c$ +r = 42
+ !$ bar = 62
+!$ bar = bar + 1
+ if (bar.ne.26) call abort
+ baz = bar
+*$ 0baz = 5
+C$ +12! Comment
+c$ !4
+!$ +!Another comment
+*$ &2
+!$ X baz = 0 ! Not valid OpenMP conditional compilation lines
+! $ baz = 1
+c$ 10&baz = 2
+ if (baz.ne.26) call abort
+ end
--- /dev/null
+! Test conditional compilation in free form if -fopenmp
+! { dg-options "-fopenmp" }
+ 10 foo = 2&
+ &56
+ if (foo.ne.256) call abort
+ bar = 26
+ !$ 20 ba&
+!$ &r = 4&
+ !$2
+ !$bar = 62
+ !$ bar = bar + 2
+#ifdef _OPENMP
+bar = bar - 1
+#endif
+ if (bar.ne.43) call abort
+ baz = bar
+!$ 30 baz = 5& ! Comment
+!$12 &
+ !$ + 2
+!$X baz = 0 ! Not valid OpenMP conditional compilation lines
+! $ baz = 1
+baz = baz + 1 !$ baz = 2
+ if (baz.ne.515) call abort
+ end
--- /dev/null
+! Test conditional compilation in free form if -fno-openmp
+! { dg-options "-fno-openmp" }
+ 10 foo = 2&
+ &56
+ if (foo.ne.256) call abort
+ bar = 26
+ !$ 20 ba&
+!$ &r = 4&
+ !$2
+ !$bar = 62
+ !$ bar = bar + 2
+#ifdef _OPENMP
+bar = bar - 1
+#endif
+ if (bar.ne.26) call abort
+ baz = bar
+!$ 30 baz = 5& ! Comment
+!$12 &
+ !$ + 2
+!$X baz = 0 ! Not valid OpenMP conditional compilation lines
+! $ baz = 1
+baz = baz + 1 !$ baz = 2
+ if (baz.ne.27) call abort
+ end
--- /dev/null
+C******************************************************************************
+C FILE: omp_hello.f
+C DESCRIPTION:
+C OpenMP Example - Hello World - Fortran Version
+C In this simple example, the master thread forks a parallel region.
+C All threads in the team obtain their unique thread number and print it.
+C The master thread only prints the total number of threads. Two OpenMP
+C library routines are used to obtain the number of threads and each
+C thread's number.
+C AUTHOR: Blaise Barney 5/99
+C LAST REVISED:
+C******************************************************************************
+
+ PROGRAM HELLO
+
+ INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,
+ + OMP_GET_THREAD_NUM
+
+C Fork a team of threads giving them their own copies of variables
+!$OMP PARALLEL PRIVATE(NTHREADS, TID)
+
+
+C Obtain thread number
+ TID = OMP_GET_THREAD_NUM()
+ PRINT *, 'Hello World from thread = ', TID
+
+C Only master thread does this
+ IF (TID .EQ. 0) THEN
+ NTHREADS = OMP_GET_NUM_THREADS()
+ PRINT *, 'Number of threads = ', NTHREADS
+ END IF
+
+C All threads join master thread and disband
+!$OMP END PARALLEL
+
+ END
--- /dev/null
+C******************************************************************************
+C FILE: omp_orphan.f
+C DESCRIPTION:
+C OpenMP Example - Parallel region with an orphaned directive - Fortran
+C Version
+C This example demonstrates a dot product being performed by an orphaned
+C loop reduction construct. Scoping of the reduction variable is critical.
+C AUTHOR: Blaise Barney 5/99
+C LAST REVISED:
+C******************************************************************************
+
+ PROGRAM ORPHAN
+ COMMON /DOTDATA/ A, B, SUM
+ INTEGER I, VECLEN
+ PARAMETER (VECLEN = 100)
+ REAL*8 A(VECLEN), B(VECLEN), SUM
+
+ DO I=1, VECLEN
+ A(I) = 1.0 * I
+ B(I) = A(I)
+ ENDDO
+ SUM = 0.0
+!$OMP PARALLEL
+ CALL DOTPROD
+!$OMP END PARALLEL
+ WRITE(*,*) "Sum = ", SUM
+ END
+
+
+
+ SUBROUTINE DOTPROD
+ COMMON /DOTDATA/ A, B, SUM
+ INTEGER I, TID, OMP_GET_THREAD_NUM, VECLEN
+ PARAMETER (VECLEN = 100)
+ REAL*8 A(VECLEN), B(VECLEN), SUM
+
+ TID = OMP_GET_THREAD_NUM()
+!$OMP DO REDUCTION(+:SUM)
+ DO I=1, VECLEN
+ SUM = SUM + (A(I)*B(I))
+ PRINT *, ' TID= ',TID,'I= ',I
+ ENDDO
+ RETURN
+ END
--- /dev/null
+! { dg-do run }
+use omp_lib
+ call test_parallel
+ call test_do
+ call test_sections
+ call test_single
+
+contains
+ subroutine test_parallel
+ integer :: a, b, c, e, f, g, i, j
+ integer, dimension (20) :: d
+ logical :: h
+ a = 6
+ b = 8
+ c = 11
+ d(:) = -1
+ e = 13
+ f = 24
+ g = 27
+ h = .false.
+ i = 1
+ j = 16
+!$omp para&
+!$omp&llel &
+!$omp if (a .eq. 6) private (b, c) shared (d) private (e) &
+ !$omp firstprivate(f) num_threads (a - 1) first&
+!$ompprivate(g)default (shared) reduction (.or. : h) &
+!$omp reduction(*:i)
+ if (i .ne. 1) h = .true.
+ i = 2
+ if (f .ne. 24) h = .true.
+ if (g .ne. 27) h = .true.
+ e = 7
+ b = omp_get_thread_num ()
+ if (b .eq. 0) j = 24
+ f = b
+ g = f
+ c = omp_get_num_threads ()
+ if (c .gt. a - 1 .or. c .le. 0) h = .true.
+ if (b .ge. c) h = .true.
+ d(b + 1) = c
+ if (f .ne. g .or. f .ne. b) h = .true.
+!$omp endparallel
+ if (h) call abort
+ if (a .ne. 6) call abort
+ if (j .ne. 24) call abort
+ if (d(1) .eq. -1) call abort
+ e = 1
+ do g = 1, d(1)
+ if (d(g) .ne. d(1)) call abort
+ e = e * 2
+ end do
+ if (e .ne. i) call abort
+ end subroutine test_parallel
+
+ subroutine test_do_orphan
+ integer :: k, l
+!$omp parallel do private (l)
+ do 600 k = 1, 16, 2
+600 l = k
+ end subroutine test_do_orphan
+
+ subroutine test_do
+ integer :: i, j, k, l, n
+ integer, dimension (64) :: d
+ logical :: m
+
+ j = 16
+ d(:) = -1
+ m = .true.
+ n = 24
+!$omp parallel num_threads (4) shared (i, k, d) private (l) &
+!$omp&reduction (.and. : m)
+ if (omp_get_thread_num () .eq. 0) then
+ k = omp_get_num_threads ()
+ end if
+ call test_do_orphan
+!$omp do schedule (static) firstprivate (n)
+ do 200 i = 1, j
+ if (i .eq. 1 .and. n .ne. 24) call abort
+ n = i
+200 d(n) = omp_get_thread_num ()
+!$omp enddo nowait
+
+!$omp do lastprivate (i) schedule (static, 5)
+ do 201 i = j + 1, 2 * j
+201 d(i) = omp_get_thread_num () + 1024
+ ! Implied omp end do here
+
+ if (i .ne. 33) m = .false.
+
+!$omp do private (j) schedule (dynamic)
+ do i = 33, 48
+ d(i) = omp_get_thread_num () + 2048
+ end do
+!$omp end do nowait
+
+!$omp do schedule (runtime)
+ do i = 49, 4 * j
+ d(i) = omp_get_thread_num () + 4096
+ end do
+ ! Implied omp end do here
+!$omp end parallel
+ if (.not. m) call abort
+
+ j = 0
+ do i = 1, 64
+ if (d(i) .lt. j .or. d(i) .ge. j + k) call abort
+ if (i .eq. 16) j = 1024
+ if (i .eq. 32) j = 2048
+ if (i .eq. 48) j = 4096
+ end do
+ end subroutine test_do
+
+ subroutine test_sections
+ integer :: i, j, k, l, m, n
+ i = 9
+ j = 10
+ k = 11
+ l = 0
+ m = 0
+ n = 30
+ call omp_set_dynamic (.false.)
+ call omp_set_num_threads (4)
+!$omp parallel num_threads (4)
+!$omp sections private (i) firstprivate (j, k) lastprivate (j) &
+!$omp& reduction (+ : l, m)
+!$omp section
+ i = 24
+ if (j .ne. 10 .or. k .ne. 11 .or. m .ne. 0) l = 1
+ m = m + 4
+!$omp section
+ i = 25
+ if (j .ne. 10 .or. k .ne. 11) l = 1
+ m = m + 6
+!$omp section
+ i = 26
+ if (j .ne. 10 .or. k .ne. 11) l = 1
+ m = m + 8
+!$omp section
+ i = 27
+ if (j .ne. 10 .or. k .ne. 11) l = 1
+ m = m + 10
+ j = 271
+!$omp end sections nowait
+!$omp sections lastprivate (n)
+!$omp section
+ n = 6
+!$omp section
+ n = 7
+!$omp endsections
+!$omp end parallel
+ if (j .ne. 271 .or. l .ne. 0) call abort
+ if (m .ne. 4 + 6 + 8 + 10) call abort
+ if (n .ne. 7) call abort
+ end subroutine test_sections
+
+ subroutine test_single
+ integer :: i, j, k, l
+ logical :: m
+ i = 200
+ j = 300
+ k = 400
+ l = 500
+ m = .false.
+!$omp parallel num_threads (4), private (i, j), reduction (.or. : m)
+ i = omp_get_thread_num ()
+ j = omp_get_thread_num ()
+!$omp single private (k)
+ k = 64
+!$omp end single nowait
+!$omp single private (k) firstprivate (l)
+ if (i .ne. omp_get_thread_num () .or. i .ne. j) then
+ j = -1
+ else
+ j = -2
+ end if
+ if (l .ne. 500) j = -1
+ l = 265
+!$omp end single copyprivate (j)
+ if (i .ne. omp_get_thread_num () .or. j .ne. -2) m = .true.
+!$omp endparallel
+ if (m) call abort
+ end subroutine test_single
+end
--- /dev/null
+! { dg-do run }
+use omp_lib
+ call test_master
+ call test_critical
+ call test_barrier
+ call test_atomic
+
+contains
+ subroutine test_master
+ logical :: i, j
+ i = .false.
+ j = .false.
+!$omp parallel num_threads (4)
+!$omp master
+ i = .true.
+ j = omp_get_thread_num () .eq. 0
+!$omp endmaster
+!$omp end parallel
+ if (.not. (i .or. j)) call abort
+ end subroutine test_master
+
+ subroutine test_critical_1 (i, j)
+ integer :: i, j
+!$omp critical(critical_foo)
+ i = i + 1
+!$omp end critical (critical_foo)
+!$omp critical
+ j = j + 1
+!$omp end critical
+ end subroutine test_critical_1
+
+ subroutine test_critical
+ integer :: i, j, n
+ n = -1
+ i = 0
+ j = 0
+!$omp parallel num_threads (4)
+ if (omp_get_thread_num () .eq. 0) n = omp_get_num_threads ()
+ call test_critical_1 (i, j)
+ call test_critical_1 (i, j)
+!$omp critical
+ j = j + 1
+!$omp end critical
+!$omp critical (critical_foo)
+ i = i + 1
+!$omp endcritical (critical_foo)
+!$omp end parallel
+ if (n .lt. 1 .or. i .ne. n * 3 .or. j .ne. n * 3) call abort
+ end subroutine test_critical
+
+ subroutine test_barrier
+ integer :: i
+ logical :: j
+ i = 23
+ j = .false.
+!$omp parallel num_threads (4)
+ if (omp_get_thread_num () .eq. 0) i = 5
+!$omp flush (i)
+!$omp barrier
+ if (i .ne. 5) then
+!$omp atomic
+ j = j .or. .true.
+ end if
+!$omp end parallel
+ if (i .ne. 5 .or. j) call abort
+ end subroutine test_barrier
+
+ subroutine test_atomic
+ integer :: a, b, c, d, e, f, g
+ a = 0
+ b = 1
+ c = 0
+ d = 1024
+ e = 1024
+ f = -1
+ g = -1
+!$omp parallel num_threads (8)
+!$omp atomic
+ a = a + 2 + 4
+!$omp atomic
+ b = 3 * b
+!$omp atomic
+ c = 8 - c
+!$omp atomic
+ d = d / 2
+!$omp atomic
+ e = min (e, omp_get_thread_num ())
+!$omp atomic
+ f = max (omp_get_thread_num (), f)
+ if (omp_get_thread_num () .eq. 0) g = omp_get_num_threads ()
+!$omp end parallel
+ if (g .le. 0 .or. g .gt. 8) call abort
+ if (a .ne. 6 * g .or. b .ne. 3 ** g) call abort
+ if (iand (g, 1) .eq. 1) then
+ if (c .ne. 8) call abort
+ else if (c .ne. 0) then
+ call abort
+ end if
+ if (d .ne. 1024 / (2 ** g)) call abort
+ if (e .ne. 0 .or. f .ne. g - 1) call abort
+ end subroutine test_atomic
+end
--- /dev/null
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+use omp_lib
+ common /tlsblock/ x, y
+ integer :: x, y, z
+ save z
+!$omp threadprivate (/tlsblock/, z)
+
+ call test_flush
+ call test_ordered
+ call test_threadprivate
+
+contains
+ subroutine test_flush
+ integer :: i, j
+ i = 0
+ j = 0
+!$omp parallel num_threads (4)
+ if (omp_get_thread_num () .eq. 0) i = omp_get_num_threads ()
+ if (omp_get_thread_num () .eq. 0) j = j + 1
+!$omp flush (i, j)
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) j = j + 2
+!$omp flush
+!$omp barrier
+ if (omp_get_thread_num () .eq. 2) j = j + 3
+!$omp flush (i)
+!$omp flush (j)
+!$omp barrier
+ if (omp_get_thread_num () .eq. 3) j = j + 4
+!$omp end parallel
+ end subroutine test_flush
+
+ subroutine test_ordered
+ integer :: i, j
+ integer, dimension (100) :: d
+ d(:) = -1
+!$omp parallel do ordered schedule (dynamic) num_threads (4)
+ do i = 1, 100, 5
+!$omp ordered
+ d(i) = i
+!$omp end ordered
+ end do
+ j = 1
+ do 100 i = 1, 100
+ if (i .eq. j) then
+ if (d(i) .ne. i) call abort
+ j = i + 5
+ else
+ if (d(i) .ne. -1) call abort
+ end if
+100 d(i) = -1
+ end subroutine test_ordered
+
+ subroutine test_threadprivate
+ common /tlsblock/ x, y
+!$omp threadprivate (/tlsblock/)
+ integer :: i, j
+ logical :: m, n
+ call omp_set_num_threads (4)
+ call omp_set_dynamic (.false.)
+ i = -1
+ x = 6
+ y = 7
+ z = 8
+ n = .false.
+ m = .false.
+!$omp parallel copyin (/tlsblock/, z) reduction (.or.:m) &
+!$omp& num_threads (4)
+ if (omp_get_thread_num () .eq. 0) i = omp_get_num_threads ()
+ if (x .ne. 6 .or. y .ne. 7 .or. z .ne. 8) call abort
+ x = omp_get_thread_num ()
+ y = omp_get_thread_num () + 1024
+ z = omp_get_thread_num () + 4096
+!$omp end parallel
+ if (x .ne. 0 .or. y .ne. 1024 .or. z .ne. 4096) call abort
+!$omp parallel num_threads (4), private (j) reduction (.or.:n)
+ if (omp_get_num_threads () .eq. i) then
+ j = omp_get_thread_num ()
+ if (x .ne. j .or. y .ne. j + 1024 .or. z .ne. j + 4096) &
+& call abort
+ end if
+!$omp end parallel
+ m = m .or. n
+ n = .false.
+!$omp parallel num_threads (4), copyin (z) reduction (.or. : n)
+ if (z .ne. 4096) n = .true.
+ if (omp_get_num_threads () .eq. i) then
+ j = omp_get_thread_num ()
+ if (x .ne. j .or. y .ne. j + 1024) call abort
+ end if
+!$omp end parallel
+ if (m .or. n) call abort
+ end subroutine test_threadprivate
+end
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+ call test_workshare
+
+contains
+ subroutine test_workshare
+ integer :: i, j, k, l, m
+ double precision, dimension (64) :: d, e
+ integer, dimension (10) :: f, g
+ integer, dimension (16, 16) :: a, b, c
+ integer, dimension (16) :: n
+ d(:) = 1
+ e = 7
+ f = 10
+ l = 256
+ m = 512
+ g(1:3) = -1
+ g(4:6) = 0
+ g(7:8) = 5
+ g(9:10) = 10
+ forall (i = 1:16, j = 1:16) a (i, j) = i * 16 + j
+ forall (j = 1:16) n (j) = j
+!$omp parallel num_threads (4) private (j, k)
+!$omp barrier
+!$omp workshare
+ i = 6
+ e(:) = d(:)
+ where (g .lt. 0)
+ f = 100
+ elsewhere (g .eq. 0)
+ f = 200 + f
+ elsewhere
+ where (g .gt. 6) f = f + sum (g)
+ f = 300 + f
+ end where
+ where (f .gt. 210) g = 0
+!$omp end workshare nowait
+!$omp workshare
+ forall (j = 1:16, k = 1:16) b (k, j) = a (j, k)
+ forall (k = 1:16) c (k, 1:16) = a (1:16, k)
+ forall (j = 2:16, n (17 - j) / 4 * 4 .ne. n (17 - j))
+ n (j) = n (j - 1) * n (j)
+ end forall
+!$omp endworkshare
+!$omp workshare
+!$omp atomic
+ i = i + 8 + 6
+!$omp critical
+!$omp critical (critical_foox)
+ l = 128
+!$omp end critical (critical_foox)
+!$omp endcritical
+!$omp parallel num_threads (2)
+!$ if (omp_get_thread_num () .eq. 0) m = omp_get_num_threads ()
+!$omp atomic
+ l = 1 + l
+!$omp end parallel
+!$omp end workshare
+!$omp end parallel
+
+ if (any (f .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) &
+& call abort
+ if (any (g .ne. (/-1, -1, -1, 0, 0, 0, 0, 0, 0, 0/))) call abort
+ if (i .ne. 20) call abort
+!$ if (l .ne. 128 + m) call abort
+ if (any (d .ne. 1 .or. e .ne. 1)) call abort
+ if (any (b .ne. transpose (a))) call abort
+ if (any (c .ne. b)) call abort
+ if (any (n .ne. (/1, 2, 6, 12, 5, 30, 42, 56, 9, 90, &
+& 110, 132, 13, 182, 210, 240/))) call abort
+ end subroutine test_workshare
+end
--- /dev/null
+C******************************************************************************
+C FILE: omp_reduction.f
+C DESCRIPTION:
+C OpenMP Example - Combined Parallel Loop Reduction - Fortran Version
+C This example demonstrates a sum reduction within a combined parallel loop
+C construct. Notice that default data element scoping is assumed - there
+C are no clauses specifying shared or private variables. OpenMP will
+C automatically make loop index variables private within team threads, and
+C global variables shared.
+C AUTHOR: Blaise Barney 5/99
+C LAST REVISED:
+C******************************************************************************
+
+ PROGRAM REDUCTION
+
+ INTEGER I, N
+ REAL A(100), B(100), SUM
+
+! Some initializations
+ N = 100
+ DO I = 1, N
+ A(I) = I *1.0
+ B(I) = A(I)
+ ENDDO
+ SUM = 0.0
+
+!$OMP PARALLEL DO REDUCTION(+:SUM)
+ DO I = 1, N
+ SUM = SUM + (A(I) * B(I))
+ ENDDO
+
+ PRINT *, ' Sum = ', SUM
+ END
--- /dev/null
+C******************************************************************************
+C FILE: omp_workshare1.f
+C DESCRIPTION:
+C OpenMP Example - Loop Work-sharing - Fortran Version
+C In this example, the iterations of a loop are scheduled dynamically
+C across the team of threads. A thread will perform CHUNK iterations
+C at a time before being scheduled for the next CHUNK of work.
+C AUTHOR: Blaise Barney 5/99
+C LAST REVISED: 01/09/04
+C******************************************************************************
+
+ PROGRAM WORKSHARE1
+
+ INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,
+ + OMP_GET_THREAD_NUM, N, CHUNKSIZE, CHUNK, I
+ PARAMETER (N=100)
+ PARAMETER (CHUNKSIZE=10)
+ REAL A(N), B(N), C(N)
+
+! Some initializations
+ DO I = 1, N
+ A(I) = I * 1.0
+ B(I) = A(I)
+ ENDDO
+ CHUNK = CHUNKSIZE
+
+!$OMP PARALLEL SHARED(A,B,C,NTHREADS,CHUNK) PRIVATE(I,TID)
+
+ TID = OMP_GET_THREAD_NUM()
+ IF (TID .EQ. 0) THEN
+ NTHREADS = OMP_GET_NUM_THREADS()
+ PRINT *, 'Number of threads =', NTHREADS
+ END IF
+ PRINT *, 'Thread',TID,' starting...'
+
+!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
+ DO I = 1, N
+ C(I) = A(I) + B(I)
+ WRITE(*,100) TID,I,C(I)
+ 100 FORMAT(' Thread',I2,': C(',I3,')=',F8.2)
+ ENDDO
+!$OMP END DO NOWAIT
+
+ PRINT *, 'Thread',TID,' done.'
+
+!$OMP END PARALLEL
+
+ END
--- /dev/null
+C******************************************************************************
+C FILE: omp_workshare2.f
+C DESCRIPTION:
+C OpenMP Example - Sections Work-sharing - Fortran Version
+C In this example, the OpenMP SECTION directive is used to assign
+C different array operations to threads that execute a SECTION. Each
+C thread receives its own copy of the result array to work with.
+C AUTHOR: Blaise Barney 5/99
+C LAST REVISED: 01/09/04
+C******************************************************************************
+
+ PROGRAM WORKSHARE2
+
+ INTEGER N, I, NTHREADS, TID, OMP_GET_NUM_THREADS,
+ + OMP_GET_THREAD_NUM
+ PARAMETER (N=50)
+ REAL A(N), B(N), C(N)
+
+! Some initializations
+ DO I = 1, N
+ A(I) = I * 1.0
+ B(I) = A(I)
+ ENDDO
+
+!$OMP PARALLEL SHARED(A,B,NTHREADS), PRIVATE(C,I,TID)
+ TID = OMP_GET_THREAD_NUM()
+ IF (TID .EQ. 0) THEN
+ NTHREADS = OMP_GET_NUM_THREADS()
+ PRINT *, 'Number of threads =', NTHREADS
+ END IF
+ PRINT *, 'Thread',TID,' starting...'
+
+!$OMP SECTIONS
+
+!$OMP SECTION
+ PRINT *, 'Thread',TID,' doing section 1'
+ DO I = 1, N
+ C(I) = A(I) + B(I)
+ WRITE(*,100) TID,I,C(I)
+ 100 FORMAT(' Thread',I2,': C(',I2,')=',F8.2)
+ ENDDO
+
+!$OMP SECTION
+ PRINT *, 'Thread',TID,' doing section 2'
+ DO I = 1+N/2, N
+ C(I) = A(I) * B(I)
+ WRITE(*,100) TID,I,C(I)
+ ENDDO
+
+!$OMP END SECTIONS NOWAIT
+
+ PRINT *, 'Thread',TID,' done.'
+
+!$OMP END PARALLEL
+
+ END
--- /dev/null
+C PR fortran/25162
+C { dg-do run }
+C { dg-require-effective-target tls_runtime }
+ PROGRAM PR25162
+ CALL TEST1
+ CALL TEST2
+ END
+ SUBROUTINE TEST1
+ DOUBLE PRECISION BPRIM
+ COMMON /TESTCOM/ BPRIM(100)
+C$OMP THREADPRIVATE(/TESTCOM/)
+ INTEGER I
+ DO I = 1, 100
+ BPRIM( I ) = DBLE( I )
+ END DO
+ RETURN
+ END
+ SUBROUTINE TEST2
+ DOUBLE PRECISION BPRIM
+ COMMON /TESTCOM/ BPRIM(100)
+C$OMP THREADPRIVATE(/TESTCOM/)
+ INTEGER I, IDUM(50)
+ DO I = 1, 50
+ IDUM(I) = I
+ END DO
+C$OMP PARALLEL COPYIN(/TESTCOM/) NUM_THREADS(4)
+ CALL TEST3
+C$OMP END PARALLEL
+ RETURN
+ END
+ SUBROUTINE TEST3
+ DOUBLE PRECISION BPRIM
+ COMMON /TESTCOM/ BPRIM(100)
+C$OMP THREADPRIVATE(/TESTCOM/)
+ INTEGER K
+ DO K = 1, 10
+ IF (K.NE.BPRIM(K)) CALL ABORT
+ END DO
+ RETURN
+ END
--- /dev/null
+! PR fortran/25219
+
+ implicit none
+ save
+ integer :: i, k
+ k = 3
+!$omp parallel
+!$omp do lastprivate (k)
+ do i = 1, 100
+ k = i
+ end do
+!$omp end do
+!$omp end parallel
+ if (k .ne. 100) call abort
+end
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+
+ integer :: i, ia (6), n, cnt
+ real :: r, ra (4)
+ double precision :: d, da (5)
+ complex :: c, ca (3)
+ logical :: v
+
+ i = 1
+ ia = 2
+ r = 3
+ ra = 4
+ d = 5.5
+ da = 6.5
+ c = cmplx (7.5, 1.5)
+ ca = cmplx (8.5, -3.0)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (+:i, ia, r, ra, d, da, c, ca)
+!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true.
+!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true.
+!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true.
+!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ c = cmplx (2.5, -3.5)
+ ca(1) = cmplx (4.5, 5)
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ c = cmplx (0.5, -3)
+ ca(2:3) = cmplx (-1, 6)
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = -1
+ d = 1
+ da = -1
+ c = 1
+ ca = cmplx (-1, 0)
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 8 .or. any (ia .ne. (/3, 3, 1, 6, 6, 8/))) call abort
+ if (r .ne. 8 .or. any (ra .ne. (/9.5, 8.0, 1.5, 1.5/))) call abort
+ if (d .ne. 12.5 .or. any (da .ne. (/8.0, 16.5, 16.5, 14.0, 5.5/))) call abort
+ if (c .ne. cmplx (11.5, -5)) call abort
+ if (ca(1) .ne. cmplx (12, 2)) call abort
+ if (ca(2) .ne. cmplx (6.5, 3) .or. ca(2) .ne. ca(3)) call abort
+ end if
+
+ i = 1
+ ia = 2
+ r = 3
+ ra = 4
+ d = 5.5
+ da = 6.5
+ c = cmplx (7.5, 1.5)
+ ca = cmplx (8.5, -3.0)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (-:i, ia, r, ra, d, da, c, ca)
+!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true.
+!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true.
+!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true.
+!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ c = cmplx (2.5, -3.5)
+ ca(1) = cmplx (4.5, 5)
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ c = cmplx (0.5, -3)
+ ca(2:3) = cmplx (-1, 6)
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = -1
+ d = 1
+ da = -1
+ c = 1
+ ca = cmplx (-1, 0)
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 8 .or. any (ia .ne. (/3, 3, 1, 6, 6, 8/))) call abort
+ if (r .ne. 8 .or. any (ra .ne. (/9.5, 8.0, 1.5, 1.5/))) call abort
+ if (d .ne. 12.5 .or. any (da .ne. (/8.0, 16.5, 16.5, 14.0, 5.5/))) call abort
+ if (c .ne. cmplx (11.5, -5)) call abort
+ if (ca(1) .ne. cmplx (12, 2)) call abort
+ if (ca(2) .ne. cmplx (6.5, 3) .or. ca(2) .ne. ca(3)) call abort
+ end if
+
+ i = 1
+ ia = 2
+ r = 4
+ ra = 8
+ d = 16
+ da = 32
+ c = 2
+ ca = cmplx (0, 2)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (*:i, ia, r, ra, d, da, c, ca)
+!$ if (i .ne. 1 .or. any (ia .ne. 1)) v = .true.
+!$ if (r .ne. 1 .or. any (ra .ne. 1)) v = .true.
+!$ if (d .ne. 1 .or. any (da .ne. 1)) v = .true.
+!$ if (c .ne. cmplx (1) .or. any (ca .ne. cmplx (1))) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 3
+ ia(3:5) = 2
+ r = 0.5
+ ra(1:2) = 2
+ d = -1
+ da(2:4) = -2
+ c = 2.5
+ ca(1) = cmplx (-5, 0)
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = -2
+ r = 8
+ ra(2:4) = -0.5
+ da(1:3) = -1
+ c = -3
+ ca(2:3) = cmplx (0, -1)
+ else
+ ia = 2
+ r = 0.5
+ ra = 0.25
+ d = 2.5
+ da = -1
+ c = cmplx (0, -1)
+ ca = cmplx (-1, 0)
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 6 .or. any (ia .ne. (/4, 4, 8, -16, -16, -8/))) call abort
+ if (r .ne. 8 .or. any (ra .ne. (/4., -2., -1., -1./))) call abort
+ if (d .ne. -40 .or. any (da .ne. (/32., -64., -64., 64., -32./))) call abort
+ if (c .ne. cmplx (0, 15)) call abort
+ if (ca(1) .ne. cmplx (0, 10)) call abort
+ if (ca(2) .ne. cmplx (-2, 0) .or. ca(2) .ne. ca(3)) call abort
+ end if
+end
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+
+ logical :: l, la (4), m, ma (4), v
+ integer :: n, cnt
+
+ l = .true.
+ la = (/.true., .false., .true., .true./)
+ m = .false.
+ ma = (/.false., .false., .false., .true./)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (.and.:l, la) reduction (.or.:m, ma)
+!$ if (.not. l .or. any (.not. la)) v = .true.
+!$ if (m .or. any (ma)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ l = .false.
+ la(3) = .false.
+ ma(2) = .true.
+ else if (n .eq. 1) then
+ l = .false.
+ la(4) = .false.
+ ma(1) = .true.
+ else
+ la(3) = .false.
+ m = .true.
+ ma(1) = .true.
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (l .or. any (la .neqv. (/.true., .false., .false., .false./))) call abort
+ if (.not. m .or. any (ma .neqv. (/.true., .true., .false., .true./))) call abort
+ end if
+
+ l = .true.
+ la = (/.true., .false., .true., .true./)
+ m = .false.
+ ma = (/.false., .false., .false., .true./)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (.eqv.:l, la) reduction (.neqv.:m, ma)
+!$ if (.not. l .or. any (.not. la)) v = .true.
+!$ if (m .or. any (ma)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ l = .false.
+ la(3) = .false.
+ ma(2) = .true.
+ else if (n .eq. 1) then
+ l = .false.
+ la(4) = .false.
+ ma(1) = .true.
+ else
+ la(3) = .false.
+ m = .true.
+ ma(1) = .true.
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (.not. l .or. any (la .neqv. (/.true., .false., .true., .false./))) call abort
+ if (.not. m .or. any (ma .neqv. (/.false., .true., .false., .true./))) call abort
+ end if
+
+end
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+
+ integer (kind = 4) :: i, ia (6), n, cnt
+ real :: r, ra (4)
+ double precision :: d, da (5)
+ logical :: v
+
+ i = 1
+ ia = 2
+ r = 3
+ ra = 4
+ d = 5.5
+ da = 6.5
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (max:i, ia, r, ra, d, da)
+!$ if (i .ne. -2147483648 .or. any (ia .ne. -2147483648)) v = .true.
+!$ if (r .ge. -1.0d38 .or. any (ra .ge. -1.0d38)) v = .true.
+!$ if (d .ge. -1.0d300 .or. any (da .ge. -1.0d300)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ ia(1) = 7
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = -1
+ d = 1
+ da = -1
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 4 .or. any (ia .ne. (/7, 2, 2, 5, 5, 5/))) call abort
+ if (r .ne. 5 .or. any (ra .ne. (/6.5, 6.5, 4., 4./))) call abort
+ if (d .ne. 8.5 .or. any (da .ne. (/6.5, 8.5, 8.5, 8.5, 6.5/))) call abort
+ end if
+
+ i = 1
+ ia = 2
+ r = 3
+ ra = 4
+ d = 5.5
+ da = 6.5
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (min:i, ia, r, ra, d, da)
+!$ if (i .ne. 2147483647 .or. any (ia .ne. 2147483647)) v = .true.
+!$ if (r .le. 1.0d38 .or. any (ra .le. 1.0d38)) v = .true.
+!$ if (d .le. 1.0d300 .or. any (da .le. 1.0d300)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ ia(1) = 7
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = 7
+ ra(3) = -8.5
+ d = 1
+ da(1:4) = 6
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 1 .or. any (ia .ne. (/1, 1, -2, -2, -2, 1/))) call abort
+ if (r .ne. -1 .or. any (ra .ne. (/4., -1.5, -8.5, -1.5/))) call abort
+ if (d .ne. -2.5 .or. any (da .ne. (/2.5, 2.5, 2.5, 6., 6.5/))) call abort
+ end if
+end
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+
+ integer (kind = 4) :: i, ia (6), j, ja (6), k, ka (6), ta (6), n, cnt, x
+ logical :: v
+
+ i = Z'ffff0f'
+ ia = Z'f0ff0f'
+ j = Z'0f0000'
+ ja = Z'0f5a00'
+ k = Z'055aa0'
+ ka = Z'05a5a5'
+ v = .false.
+ cnt = -1
+ x = Z'ffffffff'
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (iand:i, ia) reduction (ior:j, ja) reduction (ieor:k, ka)
+!$ if (i .ne. x .or. any (ia .ne. x)) v = .true.
+!$ if (j .ne. 0 .or. any (ja .ne. 0)) v = .true.
+!$ if (k .ne. 0 .or. any (ka .ne. 0)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = Z'ff7fff'
+ ia(3:5) = Z'fffff1'
+ j = Z'078000'
+ ja(1:3) = 1
+ k = Z'78'
+ ka(3:6) = Z'f0f'
+ else if (n .eq. 1) then
+ i = Z'ffff77'
+ ia(2:5) = Z'ffafff'
+ j = Z'007800'
+ ja(2:5) = 8
+ k = Z'57'
+ ka(3:4) = Z'f0108'
+ else
+ i = Z'777fff'
+ ia(1:2) = Z'fffff3'
+ j = Z'000780'
+ ja(5:6) = Z'f00'
+ k = Z'1000'
+ ka(6:6) = Z'777'
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ ta = (/Z'f0ff03', Z'f0af03', Z'f0af01', Z'f0af01', Z'f0af01', Z'f0ff0f'/)
+ if (i .ne. Z'777f07' .or. any (ia .ne. ta)) call abort
+ ta = (/Z'f5a01', Z'f5a09', Z'f5a09', Z'f5a08', Z'f5f08', Z'f5f00'/)
+ if (j .ne. Z'fff80' .or. any (ja .ne. ta)) call abort
+ ta = (/Z'5a5a5', Z'5a5a5', Z'aaba2', Z'aaba2', Z'5aaaa', Z'5addd'/)
+ if (k .ne. Z'54a8f' .or. any (ka .ne. ta)) call abort
+ end if
+end
--- /dev/null
+! { dg-do run }
+
+module reduction5
+ intrinsic ior, min, max
+end module reduction5
+
+ call test1
+ call test2
+contains
+ subroutine test1
+ use reduction5, bitwise_or => ior
+ integer :: n
+ n = Z'f'
+!$omp parallel sections num_threads (3) reduction (bitwise_or: n)
+ n = ior (n, Z'20')
+!$omp section
+ n = bitwise_or (Z'410', n)
+!$omp section
+ n = bitwise_or (n, Z'2000')
+!$omp end parallel sections
+ if (n .ne. Z'243f') call abort
+ end subroutine
+ subroutine test2
+ use reduction5, min => max, max => min
+ integer :: m, n
+ m = 8
+ n = 4
+!$omp parallel sections num_threads (3) reduction (min: n) &
+!$omp & reduction (max: m)
+ if (m .gt. 13) m = 13
+ if (n .lt. 11) n = 11
+!$omp section
+ if (m .gt. 5) m = 5
+ if (n .lt. 15) n = 15
+!$omp section
+ if (m .gt. 3) m = 3
+ if (n .lt. -1) n = -1
+!$omp end parallel sections
+ if (m .ne. 3 .or. n .ne. 15) call abort
+ end subroutine test2
+end
--- /dev/null
+! { dg-do run }
+
+ integer, dimension (6, 6) :: a
+ character (36) :: c
+ integer nthreads
+ a = 9
+ nthreads = -1
+ call foo (a (2:4, 3:5), nthreads)
+ if (nthreads .eq. 3) then
+ write (c, '(36i1)') a
+ if (c .ne. '999999999999966699966699966699999999') call abort
+ end if
+contains
+ subroutine foo (b, nthreads)
+ use omp_lib
+ integer, dimension (3:, 5:) :: b
+ integer :: err, nthreads
+ b = 0
+ err = 0
+!$omp parallel num_threads (3) reduction (+:b)
+ if (any (b .ne. 0)) then
+!$omp atomic
+ err = err + 1
+ end if
+!$omp master
+ nthreads = omp_get_num_threads ()
+!$omp end master
+ b = 2
+!$omp end parallel
+ if (err .gt. 0) call abort
+ end subroutine foo
+end
--- /dev/null
+! { dg-do run }
+!$ use omp_lib
+
+ integer :: i, j, k
+ double precision :: d
+ i = 6
+ j = 19
+ k = 0
+ d = 24.5
+ call test (i, j, k, d)
+ if (i .ne. 38) call abort
+ if (iand (k, 255) .ne. 0) call abort
+ if (iand (k, 65280) .eq. 0) then
+ if (k .ne. 65536 * 4) call abort
+ end if
+contains
+ subroutine test (i, j, k, d)
+ integer :: i, j, k
+ double precision :: d
+
+!$omp parallel firstprivate (d) private (j) num_threads (4) reduction (+:k)
+ if (i .ne. 6 .or. d .ne. 24.5 .or. k .ne. 0) k = k + 1
+ if (omp_get_num_threads () .ne. 4) k = k + 256
+ d = d / 2
+ j = 8
+ k = k + 65536
+!$omp barrier
+ if (d .ne. 12.25 .or. j .ne. 8) k = k + 1
+!$omp single
+ i = i + 32
+!$omp end single nowait
+!$omp end parallel
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+ real, dimension (5) :: b
+ b = 5
+ call foo (b)
+contains
+ subroutine foo (a)
+ real, dimension (5) :: a
+ logical :: l
+ l = .false.
+!$omp parallel private (a) reduction (.or.:l)
+ a = 15
+ l = bar (a)
+!$omp end parallel
+ if (l) call abort
+ end subroutine
+ function bar (a)
+ real, dimension (5) :: a
+ logical :: bar
+ bar = any (a .ne. 15)
+ end function
+end
--- /dev/null
+! { dg-do run }
+
+function f1 ()
+ use omp_lib
+ real :: f1
+ logical :: l
+ f1 = 6.5
+ l = .false.
+!$omp parallel firstprivate (f1) num_threads (2) reduction (.or.:l)
+ l = f1 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) f1 = 8.5
+ if (omp_get_thread_num () .eq. 1) f1 = 14.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 14.5)
+!$omp end parallel
+ if (l) call abort
+ f1 = -2.5
+end function f1
+function f2 ()
+ use omp_lib
+ real :: f2, e2
+ logical :: l
+entry e2 ()
+ f2 = 6.5
+ l = .false.
+!$omp parallel firstprivate (e2) num_threads (2) reduction (.or.:l)
+ l = e2 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) e2 = 8.5
+ if (omp_get_thread_num () .eq. 1) e2 = 14.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. e2 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. e2 .ne. 14.5)
+!$omp end parallel
+ if (l) call abort
+ e2 = 7.5
+end function f2
+function f3 ()
+ use omp_lib
+ real :: f3, e3
+ logical :: l
+entry e3 ()
+ f3 = 6.5
+ l = .false.
+!$omp parallel firstprivate (f3, e3) num_threads (2) reduction (.or.:l)
+ l = e3 .ne. 6.5
+ l = l .or. f3 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) e3 = 8.5
+ if (omp_get_thread_num () .eq. 1) e3 = 14.5
+ f3 = e3 - 4.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. e3 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. e3 .ne. 14.5)
+ l = l .or. f3 .ne. e3 - 4.5
+!$omp end parallel
+ if (l) call abort
+ e3 = 0.5
+end function f3
+function f4 () result (r4)
+ use omp_lib
+ real :: r4, s4
+ logical :: l
+entry e4 () result (s4)
+ r4 = 6.5
+ l = .false.
+!$omp parallel firstprivate (r4, s4) num_threads (2) reduction (.or.:l)
+ l = s4 .ne. 6.5
+ l = l .or. r4 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) s4 = 8.5
+ if (omp_get_thread_num () .eq. 1) s4 = 14.5
+ r4 = s4 - 4.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. s4 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. s4 .ne. 14.5)
+ l = l .or. r4 .ne. s4 - 4.5
+!$omp end parallel
+ if (l) call abort
+ s4 = -0.5
+end function f4
+function f5 (is_f5)
+ use omp_lib
+ real :: f5
+ integer :: e5
+ logical :: l, is_f5
+entry e5 (is_f5)
+ if (is_f5) then
+ f5 = 6.5
+ else
+ e5 = 8
+ end if
+ l = .false.
+!$omp parallel firstprivate (f5, e5) shared (is_f5) num_threads (2) &
+!$omp reduction (.or.:l)
+ l = .not. is_f5 .and. e5 .ne. 8
+ l = l .or. (is_f5 .and. f5 .ne. 6.5)
+ if (omp_get_thread_num () .eq. 0) e5 = 8
+ if (omp_get_thread_num () .eq. 1) e5 = 14
+ f5 = e5 - 4.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. e5 .ne. 8)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. e5 .ne. 14)
+ l = l .or. f5 .ne. e5 - 4.5
+!$omp end parallel
+ if (l) call abort
+ if (is_f5) f5 = -2.5
+ if (.not. is_f5) e5 = 8
+end function f5
+
+ real :: f1, f2, e2, f3, e3, f4, e4, f5
+ integer :: e5
+ if (f1 () .ne. -2.5) call abort
+ if (f2 () .ne. 7.5) call abort
+ if (e2 () .ne. 7.5) call abort
+ if (f3 () .ne. 0.5) call abort
+ if (e3 () .ne. 0.5) call abort
+ if (f4 () .ne. -0.5) call abort
+ if (e4 () .ne. -0.5) call abort
+ if (f5 (.true.) .ne. -2.5) call abort
+ if (e5 (.false.) .ne. 8) call abort
+end
--- /dev/null
+! { dg-do run }
+
+ use omp_lib
+ integer :: i, j, k
+ logical :: l
+ common /b/ i, j
+ i = 4
+ j = 8
+ l = .false.
+!$omp parallel private (k) firstprivate (i) shared (j) num_threads (2) &
+!$omp& reduction (.or.:l)
+ if (i .ne. 4 .or. j .ne. 8) l = .true.
+!$omp barrier
+ k = omp_get_thread_num ()
+ if (k .eq. 0) then
+ i = 14
+ j = 15
+ end if
+!$omp barrier
+ if (k .eq. 1) then
+ if (i .ne. 4 .or. j .ne. 15) l = .true.
+ i = 24
+ j = 25
+ end if
+!$omp barrier
+ if (j .ne. 25 .or. i .ne. (k * 10 + 14)) l = .true.
+!$omp end parallel
+ if (l .or. j .ne. 25) call abort
+end
--- /dev/null
+! { dg-do run }
+
+ use omp_lib
+ integer :: i, j, k, m, n
+ logical :: l
+ equivalence (i, m)
+ equivalence (j, n)
+ i = 4
+ j = 8
+ l = .false.
+!$omp parallel private (k) firstprivate (i) shared (j) num_threads (2) &
+!$omp& reduction (.or.:l)
+ l = l .or. i .ne. 4
+ l = l .or. j .ne. 8
+!$omp barrier
+ k = omp_get_thread_num ()
+ if (k .eq. 0) then
+ i = 14
+ j = 15
+ end if
+!$omp barrier
+ if (k .eq. 1) then
+ if (i .ne. 4 .or. j .ne. 15) l = .true.
+ i = 24
+ j = 25
+ end if
+!$omp barrier
+ if (j .ne. 25 .or. i .ne. (k * 10 + 14)) l = .true.
+!$omp end parallel
+ if (l) call abort
+ if (j .ne. 25) call abort
+end
--- /dev/null
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+
+module threadprivate1
+ double precision :: d
+!$omp threadprivate (d)
+end module threadprivate1
+
+!$ use omp_lib
+ use threadprivate1
+ logical :: l
+ l = .false.
+!$omp parallel num_threads (4) reduction (.or.:l)
+ d = omp_get_thread_num () + 6.5
+!$omp barrier
+ if (d .ne. omp_get_thread_num () + 6.5) l = .true.
+!$omp end parallel
+ if (l) call abort ()
+end
--- /dev/null
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+
+module threadprivate2
+ integer, dimension(:,:), allocatable :: foo
+!$omp threadprivate (foo)
+end module threadprivate2
+
+ use omp_lib
+ use threadprivate2
+
+ integer, dimension(:), pointer :: bar1
+ integer, dimension(2), target :: bar2
+ common /thrc/ bar1, bar2
+!$omp threadprivate (/thrc/)
+
+ integer, dimension(:), pointer, save :: bar3 => NULL()
+!$omp threadprivate (bar3)
+
+ logical :: l
+ type tt
+ integer :: a
+ integer :: b = 32
+ end type tt
+ type (tt), save :: baz
+!$omp threadprivate (baz)
+
+ l = .false.
+ call omp_set_dynamic (.false.)
+ call omp_set_num_threads (4)
+
+!$omp parallel num_threads (4) reduction (.or.:l)
+ l = allocated (foo)
+ allocate (foo (6 + omp_get_thread_num (), 3))
+ l = l.or..not.allocated (foo)
+ l = l.or.size (foo).ne.(18 + 3 * omp_get_thread_num ())
+ foo = omp_get_thread_num () + 1
+
+ bar2 = omp_get_thread_num ()
+ l = l.or.associated (bar3)
+ bar1 => bar2
+ l = l.or..not.associated (bar1)
+ l = l.or..not.associated (bar1, bar2)
+ l = l.or.any (bar1.ne.omp_get_thread_num ())
+ nullify (bar1)
+ l = l.or.associated (bar1)
+ allocate (bar3 (4))
+ l = l.or..not.associated (bar3)
+ bar3 = omp_get_thread_num () - 2
+
+ l = l.or.(baz%b.ne.32)
+ baz%a = omp_get_thread_num () * 2
+ baz%b = omp_get_thread_num () * 2 + 1
+!$omp end parallel
+
+ if (l) call abort
+ if (.not.allocated (foo)) call abort
+ if (size (foo).ne.18) call abort
+ if (any (foo.ne.1)) call abort
+
+ if (associated (bar1)) call abort
+ if (.not.associated (bar3)) call abort
+ if (any (bar3 .ne. -2)) call abort
+ deallocate (bar3)
+ if (associated (bar3)) call abort
+
+!$omp parallel num_threads (4) reduction (.or.:l)
+ l = l.or..not.allocated (foo)
+ l = l.or.size (foo).ne.(18 + 3 * omp_get_thread_num ())
+ l = l.or.any (foo.ne.(omp_get_thread_num () + 1))
+ if (omp_get_thread_num () .ne. 0) then
+ deallocate (foo)
+ l = l.or.allocated (foo)
+ end if
+
+ l = l.or.associated (bar1)
+ if (omp_get_thread_num () .ne. 0) then
+ l = l.or..not.associated (bar3)
+ l = l.or.any (bar3 .ne. omp_get_thread_num () - 2)
+ deallocate (bar3)
+ end if
+ l = l.or.associated (bar3)
+
+ l = l.or.(baz%a.ne.(omp_get_thread_num () * 2))
+ l = l.or.(baz%b.ne.(omp_get_thread_num () * 2 + 1))
+!$omp end parallel
+
+ if (l) call abort
+ if (.not.allocated (foo)) call abort
+ if (size (foo).ne.18) call abort
+ if (any (foo.ne.1)) call abort
+ deallocate (foo)
+ if (allocated (foo)) call abort
+end
--- /dev/null
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+
+module threadprivate3
+ integer, dimension(:,:), pointer :: foo => NULL()
+!$omp threadprivate (foo)
+end module threadprivate3
+
+ use omp_lib
+ use threadprivate3
+
+ integer, dimension(:), pointer :: bar1
+ integer, dimension(2), target :: bar2, var
+ common /thrc/ bar1, bar2
+!$omp threadprivate (/thrc/)
+
+ integer, dimension(:), pointer, save :: bar3 => NULL()
+!$omp threadprivate (bar3)
+
+ logical :: l
+ type tt
+ integer :: a
+ integer :: b = 32
+ end type tt
+ type (tt), save :: baz
+!$omp threadprivate (baz)
+
+ l = .false.
+ call omp_set_dynamic (.false.)
+ call omp_set_num_threads (4)
+ var = 6
+
+!$omp parallel num_threads (4) reduction (.or.:l)
+ bar2 = omp_get_thread_num ()
+ l = associated (bar3)
+ bar1 => bar2
+ l = l.or..not.associated (bar1)
+ l = l.or..not.associated (bar1, bar2)
+ l = l.or.any (bar1.ne.omp_get_thread_num ())
+ nullify (bar1)
+ l = l.or.associated (bar1)
+ allocate (bar3 (4))
+ l = l.or..not.associated (bar3)
+ bar3 = omp_get_thread_num () - 2
+ if (omp_get_thread_num () .ne. 0) then
+ deallocate (bar3)
+ if (associated (bar3)) call abort
+ else
+ bar1 => var
+ end if
+ bar2 = omp_get_thread_num () * 6 + 130
+
+ l = l.or.(baz%b.ne.32)
+ baz%a = omp_get_thread_num () * 2
+ baz%b = omp_get_thread_num () * 2 + 1
+!$omp end parallel
+
+ if (l) call abort
+ if (.not.associated (bar1)) call abort
+ if (any (bar1.ne.6)) call abort
+ if (.not.associated (bar3)) call abort
+ if (any (bar3 .ne. -2)) call abort
+ deallocate (bar3)
+ if (associated (bar3)) call abort
+
+ allocate (bar3 (10))
+ bar3 = 17
+
+!$omp parallel copyin (bar1, bar2, bar3, baz) num_threads (4) &
+!$omp& reduction (.or.:l)
+ l = l.or..not.associated (bar1)
+ l = l.or.any (bar1.ne.6)
+ l = l.or.any (bar2.ne.130)
+ l = l.or..not.associated (bar3)
+ l = l.or.size (bar3).ne.10
+ l = l.or.any (bar3.ne.17)
+ allocate (bar1 (4))
+ bar1 = omp_get_thread_num ()
+ bar2 = omp_get_thread_num () + 8
+
+ l = l.or.(baz%a.ne.0)
+ l = l.or.(baz%b.ne.1)
+ baz%a = omp_get_thread_num () * 3 + 4
+ baz%b = omp_get_thread_num () * 3 + 5
+
+!$omp barrier
+ if (omp_get_thread_num () .eq. 0) then
+ deallocate (bar3)
+ end if
+ bar3 => bar2
+!$omp barrier
+
+ l = l.or..not.associated (bar1)
+ l = l.or..not.associated (bar3)
+ l = l.or.any (bar1.ne.omp_get_thread_num ())
+ l = l.or.size (bar1).ne.4
+ l = l.or.any (bar2.ne.omp_get_thread_num () + 8)
+ l = l.or.any (bar3.ne.omp_get_thread_num () + 8)
+ l = l.or.size (bar3).ne.2
+
+ l = l.or.(baz%a .ne. omp_get_thread_num () * 3 + 4)
+ l = l.or.(baz%b .ne. omp_get_thread_num () * 3 + 5)
+!$omp end parallel
+
+ if (l) call abort
+end
--- /dev/null
+! { dg-do run }
+
+ call test
+contains
+ subroutine check (x, y, l)
+ integer :: x, y
+ logical :: l
+ l = l .or. x .ne. y
+ end subroutine check
+
+ subroutine foo (c, d, e, f, g, h, i, j, k, n)
+ use omp_lib
+ integer :: n
+ character (len = *) :: c
+ character (len = n) :: d
+ integer, dimension (2, 3:5, n) :: e
+ integer, dimension (2, 3:n, n) :: f
+ character (len = *), dimension (5, 3:n) :: g
+ character (len = n), dimension (5, 3:n) :: h
+ real, dimension (:, :, :) :: i
+ double precision, dimension (3:, 5:, 7:) :: j
+ integer, dimension (:, :, :) :: k
+ logical :: l
+ integer :: p, q, r
+ character (len = n) :: s
+ integer, dimension (2, 3:5, n) :: t
+ integer, dimension (2, 3:n, n) :: u
+ character (len = n), dimension (5, 3:n) :: v
+ character (len = 2 * n + 24) :: w
+ integer :: x
+ character (len = 1) :: y
+ s = 'PQRSTUV'
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!'
+ l = .false.
+!$omp parallel default (none) firstprivate (c, d, e, f, g, h, i, j, k) &
+!$omp & firstprivate (s, t, u, v) reduction (.or.:l) num_threads (6) &
+!$omp private (p, q, r, w, x, y)
+ l = l .or. c .ne. 'abcdefghijkl'
+ l = l .or. d .ne. 'ABCDEFG'
+ l = l .or. s .ne. 'PQRSTUV'
+ do 100, p = 1, 2
+ do 100, q = 3, 7
+ do 100, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. '0123456789AB'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. '9876543210ZY'
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. '0123456'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. '9876543'
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. '_+|/Oo_'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. '///|||!'
+100 continue
+ do 101, p = 3, 5
+ do 101, q = 2, 6
+ do 101, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. 7.5 * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. 9.5 * p * q * r
+101 continue
+ do 102, p = 1, 5
+ do 102, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + p + 7 + 3 * q
+102 continue
+ x = omp_get_thread_num ()
+ w = ''
+ if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
+ if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
+ if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
+ if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
+ if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
+ if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ c = w(8:19)
+ d = w(1:7)
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38)
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26)
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r
+ forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r
+ s = w(20:26)
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26)
+!$omp barrier
+ y = ''
+ if (x .eq. 0) y = '0'
+ if (x .eq. 1) y = '1'
+ if (x .eq. 2) y = '2'
+ if (x .eq. 3) y = '3'
+ if (x .eq. 4) y = '4'
+ if (x .eq. 5) y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 103, p = 1, 2
+ do 103, q = 3, 7
+ do 103, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+103 continue
+ do 104, p = 3, 5
+ do 104, q = 2, 6
+ do 104, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+104 continue
+ do 105, p = 1, 5
+ do 105, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+105 continue
+ call check (size (e, 1), 2, l)
+ call check (size (e, 2), 3, l)
+ call check (size (e, 3), 7, l)
+ call check (size (e), 42, l)
+ call check (size (f, 1), 2, l)
+ call check (size (f, 2), 5, l)
+ call check (size (f, 3), 7, l)
+ call check (size (f), 70, l)
+ call check (size (g, 1), 5, l)
+ call check (size (g, 2), 5, l)
+ call check (size (g), 25, l)
+ call check (size (h, 1), 5, l)
+ call check (size (h, 2), 5, l)
+ call check (size (h), 25, l)
+ call check (size (i, 1), 3, l)
+ call check (size (i, 2), 5, l)
+ call check (size (i, 3), 7, l)
+ call check (size (i), 105, l)
+ call check (size (j, 1), 4, l)
+ call check (size (j, 2), 5, l)
+ call check (size (j, 3), 7, l)
+ call check (size (j), 140, l)
+ call check (size (k, 1), 5, l)
+ call check (size (k, 2), 1, l)
+ call check (size (k, 3), 3, l)
+ call check (size (k), 15, l)
+!$omp end parallel
+ if (l) call abort
+ end subroutine foo
+
+ subroutine test
+ character (len = 12) :: c
+ character (len = 7) :: d
+ integer, dimension (2, 3:5, 7) :: e
+ integer, dimension (2, 3:7, 7) :: f
+ character (len = 12), dimension (5, 3:7) :: g
+ character (len = 7), dimension (5, 3:7) :: h
+ real, dimension (3:5, 2:6, 1:7) :: i
+ double precision, dimension (3:6, 2:6, 1:7) :: j
+ integer, dimension (1:5, 7:7, 4:6) :: k
+ integer :: p, q, r
+ c = 'abcdefghijkl'
+ d = 'ABCDEFG'
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY'
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543'
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r
+ forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r
+ call foo (c, d, e, f, g, h, i, j, k, 7)
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+
+ call test
+contains
+ subroutine check (x, y, l)
+ integer :: x, y
+ logical :: l
+ l = l .or. x .ne. y
+ end subroutine check
+
+ subroutine foo (c, d, e, f, g, h, i, j, k, n)
+ use omp_lib
+ integer :: n
+ character (len = *) :: c
+ character (len = n) :: d
+ integer, dimension (2, 3:5, n) :: e
+ integer, dimension (2, 3:n, n) :: f
+ character (len = *), dimension (5, 3:n) :: g
+ character (len = n), dimension (5, 3:n) :: h
+ real, dimension (:, :, :) :: i
+ double precision, dimension (3:, 5:, 7:) :: j
+ integer, dimension (:, :, :) :: k
+ logical :: l
+ integer :: p, q, r
+ character (len = n) :: s
+ integer, dimension (2, 3:5, n) :: t
+ integer, dimension (2, 3:n, n) :: u
+ character (len = n), dimension (5, 3:n) :: v
+ character (len = 2 * n + 24) :: w
+ integer :: x
+ character (len = 1) :: y
+ l = .false.
+!$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) &
+!$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) &
+!$omp private (p, q, r, w, x, y)
+ x = omp_get_thread_num ()
+ w = ''
+ if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
+ if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
+ if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
+ if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
+ if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
+ if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ c = w(8:19)
+ d = w(1:7)
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38)
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26)
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r
+ forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r
+ s = w(20:26)
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26)
+!$omp barrier
+ y = ''
+ if (x .eq. 0) y = '0'
+ if (x .eq. 1) y = '1'
+ if (x .eq. 2) y = '2'
+ if (x .eq. 3) y = '3'
+ if (x .eq. 4) y = '4'
+ if (x .eq. 5) y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 103, p = 1, 2
+ do 103, q = 3, 7
+ do 103, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+103 continue
+ do 104, p = 3, 5
+ do 104, q = 2, 6
+ do 104, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+104 continue
+ do 105, p = 1, 5
+ do 105, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+105 continue
+ call check (size (e, 1), 2, l)
+ call check (size (e, 2), 3, l)
+ call check (size (e, 3), 7, l)
+ call check (size (e), 42, l)
+ call check (size (f, 1), 2, l)
+ call check (size (f, 2), 5, l)
+ call check (size (f, 3), 7, l)
+ call check (size (f), 70, l)
+ call check (size (g, 1), 5, l)
+ call check (size (g, 2), 5, l)
+ call check (size (g), 25, l)
+ call check (size (h, 1), 5, l)
+ call check (size (h, 2), 5, l)
+ call check (size (h), 25, l)
+ call check (size (i, 1), 3, l)
+ call check (size (i, 2), 5, l)
+ call check (size (i, 3), 7, l)
+ call check (size (i), 105, l)
+ call check (size (j, 1), 4, l)
+ call check (size (j, 2), 5, l)
+ call check (size (j, 3), 7, l)
+ call check (size (j), 140, l)
+ call check (size (k, 1), 5, l)
+ call check (size (k, 2), 1, l)
+ call check (size (k, 3), 3, l)
+ call check (size (k), 15, l)
+!$omp end parallel
+ if (l) call abort
+ end subroutine foo
+
+ subroutine test
+ character (len = 12) :: c
+ character (len = 7) :: d
+ integer, dimension (2, 3:5, 7) :: e
+ integer, dimension (2, 3:7, 7) :: f
+ character (len = 12), dimension (5, 3:7) :: g
+ character (len = 7), dimension (5, 3:7) :: h
+ real, dimension (3:5, 2:6, 1:7) :: i
+ double precision, dimension (3:6, 2:6, 1:7) :: j
+ integer, dimension (1:5, 7:7, 4:6) :: k
+ integer :: p, q, r
+ call foo (c, d, e, f, g, h, i, j, k, 7)
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+
+ call test
+contains
+ subroutine check (x, y, l)
+ integer :: x, y
+ logical :: l
+ l = l .or. x .ne. y
+ end subroutine check
+
+ subroutine foo (c, d, e, f, g, h, i, j, k, n)
+ use omp_lib
+ integer :: n
+ character (len = *) :: c
+ character (len = n) :: d
+ integer, dimension (2, 3:5, n) :: e
+ integer, dimension (2, 3:n, n) :: f
+ character (len = *), dimension (5, 3:n) :: g
+ character (len = n), dimension (5, 3:n) :: h
+ real, dimension (:, :, :) :: i
+ double precision, dimension (3:, 5:, 7:) :: j
+ integer, dimension (:, :, :) :: k
+ logical :: l
+ integer :: p, q, r
+ character (len = n) :: s
+ integer, dimension (2, 3:5, n) :: t
+ integer, dimension (2, 3:n, n) :: u
+ character (len = n), dimension (5, 3:n) :: v
+ character (len = 2 * n + 24) :: w
+ integer :: x, z
+ character (len = 1) :: y
+ s = 'PQRSTUV'
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!'
+ l = .false.
+!$omp parallel default (none) shared (c, d, e, f, g, h, i, j, k) &
+!$omp & shared (s, t, u, v) reduction (.or.:l) num_threads (6) &
+!$omp private (p, q, r, w, x, y)
+ l = l .or. c .ne. 'abcdefghijkl'
+ l = l .or. d .ne. 'ABCDEFG'
+ l = l .or. s .ne. 'PQRSTUV'
+ do 100, p = 1, 2
+ do 100, q = 3, 7
+ do 100, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. '0123456789AB'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. '9876543210ZY'
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. '0123456'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. '9876543'
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. '_+|/Oo_'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. '///|||!'
+100 continue
+ do 101, p = 3, 5
+ do 101, q = 2, 6
+ do 101, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. 7.5 * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. 9.5 * p * q * r
+101 continue
+ do 102, p = 1, 5
+ do 102, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + p + 7 + 3 * q
+102 continue
+ do 110 z = 0, omp_get_num_threads () - 1
+!$omp barrier
+ x = omp_get_thread_num ()
+ w = ''
+ if (z .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
+ if (z .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
+ if (z .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
+ if (z .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
+ if (z .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
+ if (z .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ if (x .eq. z) then
+ c = w(8:19)
+ d = w(1:7)
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38)
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26)
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r
+ forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r
+ s = w(20:26)
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26)
+ end if
+!$omp barrier
+ x = z
+ y = ''
+ if (x .eq. 0) y = '0'
+ if (x .eq. 1) y = '1'
+ if (x .eq. 2) y = '2'
+ if (x .eq. 3) y = '3'
+ if (x .eq. 4) y = '4'
+ if (x .eq. 5) y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 103, p = 1, 2
+ do 103, q = 3, 7
+ do 103, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+103 continue
+ do 104, p = 3, 5
+ do 104, q = 2, 6
+ do 104, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+104 continue
+ do 105, p = 1, 5
+ do 105, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+105 continue
+110 continue
+ call check (size (e, 1), 2, l)
+ call check (size (e, 2), 3, l)
+ call check (size (e, 3), 7, l)
+ call check (size (e), 42, l)
+ call check (size (f, 1), 2, l)
+ call check (size (f, 2), 5, l)
+ call check (size (f, 3), 7, l)
+ call check (size (f), 70, l)
+ call check (size (g, 1), 5, l)
+ call check (size (g, 2), 5, l)
+ call check (size (g), 25, l)
+ call check (size (h, 1), 5, l)
+ call check (size (h, 2), 5, l)
+ call check (size (h), 25, l)
+ call check (size (i, 1), 3, l)
+ call check (size (i, 2), 5, l)
+ call check (size (i, 3), 7, l)
+ call check (size (i), 105, l)
+ call check (size (j, 1), 4, l)
+ call check (size (j, 2), 5, l)
+ call check (size (j, 3), 7, l)
+ call check (size (j), 140, l)
+ call check (size (k, 1), 5, l)
+ call check (size (k, 2), 1, l)
+ call check (size (k, 3), 3, l)
+ call check (size (k), 15, l)
+!$omp end parallel
+ if (l) call abort
+ end subroutine foo
+
+ subroutine test
+ character (len = 12) :: c
+ character (len = 7) :: d
+ integer, dimension (2, 3:5, 7) :: e
+ integer, dimension (2, 3:7, 7) :: f
+ character (len = 12), dimension (5, 3:7) :: g
+ character (len = 7), dimension (5, 3:7) :: h
+ real, dimension (3:5, 2:6, 1:7) :: i
+ double precision, dimension (3:6, 2:6, 1:7) :: j
+ integer, dimension (1:5, 7:7, 4:6) :: k
+ integer :: p, q, r
+ c = 'abcdefghijkl'
+ d = 'ABCDEFG'
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY'
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543'
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r
+ forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r
+ call foo (c, d, e, f, g, h, i, j, k, 7)
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+
+ call test
+contains
+ subroutine check (x, y, l)
+ integer :: x, y
+ logical :: l
+ l = l .or. x .ne. y
+ end subroutine check
+
+ subroutine foo (c, d, e, f, g, h, i, j, k, n)
+ use omp_lib
+ integer :: n
+ character (len = *) :: c
+ character (len = n) :: d
+ integer, dimension (2, 3:5, n) :: e
+ integer, dimension (2, 3:n, n) :: f
+ character (len = *), dimension (5, 3:n) :: g
+ character (len = n), dimension (5, 3:n) :: h
+ real, dimension (:, :, :) :: i
+ double precision, dimension (3:, 5:, 7:) :: j
+ integer, dimension (:, :, :) :: k
+ logical :: l
+ integer :: p, q, r
+ character (len = n) :: s
+ integer, dimension (2, 3:5, n) :: t
+ integer, dimension (2, 3:n, n) :: u
+ character (len = n), dimension (5, 3:n) :: v
+ character (len = 2 * n + 24) :: w
+ integer :: x, z, z2
+ character (len = 1) :: y
+ s = 'PQRSTUV'
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!'
+ l = .false.
+ call omp_set_dynamic (.false.)
+ call omp_set_num_threads (6)
+!$omp parallel do default (none) firstprivate (c, d, e, f, g, h, i, j, k) &
+!$omp & firstprivate (s, t, u, v) reduction (.or.:l) num_threads (6) &
+!$omp private (p, q, r, w, x, y) schedule (static) shared (z2) &
+!$omp lastprivate (c, d, e, f, g, h, i, j, k, s, t, u, v)
+ do 110 z = 0, omp_get_num_threads () - 1
+ if (omp_get_thread_num () .eq. 0) z2 = omp_get_num_threads ()
+ l = l .or. c .ne. 'abcdefghijkl'
+ l = l .or. d .ne. 'ABCDEFG'
+ l = l .or. s .ne. 'PQRSTUV'
+ do 100, p = 1, 2
+ do 100, q = 3, 7
+ do 100, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. '0123456789AB'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. '9876543210ZY'
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. '0123456'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. '9876543'
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. '_+|/Oo_'
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. '///|||!'
+100 continue
+ do 101, p = 3, 5
+ do 101, q = 2, 6
+ do 101, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. 7.5 * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. 9.5 * p * q * r
+101 continue
+ do 102, p = 1, 5
+ do 102, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + p + 7 + 3 * q
+102 continue
+ x = omp_get_thread_num ()
+ w = ''
+ if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
+ if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
+ if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
+ if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
+ if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
+ if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ c = w(8:19)
+ d = w(1:7)
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38)
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26)
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r
+ forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r
+ s = w(20:26)
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26)
+!$omp barrier
+ y = ''
+ if (x .eq. 0) y = '0'
+ if (x .eq. 1) y = '1'
+ if (x .eq. 2) y = '2'
+ if (x .eq. 3) y = '3'
+ if (x .eq. 4) y = '4'
+ if (x .eq. 5) y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 103, p = 1, 2
+ do 103, q = 3, 7
+ do 103, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+103 continue
+ do 104, p = 3, 5
+ do 104, q = 2, 6
+ do 104, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+104 continue
+ do 105, p = 1, 5
+ do 105, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+105 continue
+ call check (size (e, 1), 2, l)
+ call check (size (e, 2), 3, l)
+ call check (size (e, 3), 7, l)
+ call check (size (e), 42, l)
+ call check (size (f, 1), 2, l)
+ call check (size (f, 2), 5, l)
+ call check (size (f, 3), 7, l)
+ call check (size (f), 70, l)
+ call check (size (g, 1), 5, l)
+ call check (size (g, 2), 5, l)
+ call check (size (g), 25, l)
+ call check (size (h, 1), 5, l)
+ call check (size (h, 2), 5, l)
+ call check (size (h), 25, l)
+ call check (size (i, 1), 3, l)
+ call check (size (i, 2), 5, l)
+ call check (size (i, 3), 7, l)
+ call check (size (i), 105, l)
+ call check (size (j, 1), 4, l)
+ call check (size (j, 2), 5, l)
+ call check (size (j, 3), 7, l)
+ call check (size (j), 140, l)
+ call check (size (k, 1), 5, l)
+ call check (size (k, 2), 1, l)
+ call check (size (k, 3), 3, l)
+ call check (size (k), 15, l)
+110 continue
+!$omp end parallel do
+ if (l) call abort
+ if (z2 == 6) then
+ x = 5
+ w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 113, p = 1, 2
+ do 113, q = 3, 7
+ do 113, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+113 continue
+ do 114, p = 3, 5
+ do 114, q = 2, 6
+ do 114, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+114 continue
+ do 115, p = 1, 5
+ do 115, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+115 continue
+ if (l) call abort
+ end if
+ end subroutine foo
+
+ subroutine test
+ character (len = 12) :: c
+ character (len = 7) :: d
+ integer, dimension (2, 3:5, 7) :: e
+ integer, dimension (2, 3:7, 7) :: f
+ character (len = 12), dimension (5, 3:7) :: g
+ character (len = 7), dimension (5, 3:7) :: h
+ real, dimension (3:5, 2:6, 1:7) :: i
+ double precision, dimension (3:6, 2:6, 1:7) :: j
+ integer, dimension (1:5, 7:7, 4:6) :: k
+ integer :: p, q, r
+ c = 'abcdefghijkl'
+ d = 'ABCDEFG'
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY'
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543'
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r
+ forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r
+ call foo (c, d, e, f, g, h, i, j, k, 7)
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+
+ call test
+contains
+ subroutine check (x, y, l)
+ integer :: x, y
+ logical :: l
+ l = l .or. x .ne. y
+ end subroutine check
+
+ subroutine foo (c, d, e, f, g, h, i, j, k, n)
+ use omp_lib
+ integer :: n
+ character (len = *) :: c
+ character (len = n) :: d
+ integer, dimension (2, 3:5, n) :: e
+ integer, dimension (2, 3:n, n) :: f
+ character (len = *), dimension (5, 3:n) :: g
+ character (len = n), dimension (5, 3:n) :: h
+ real, dimension (:, :, :) :: i
+ double precision, dimension (3:, 5:, 7:) :: j
+ integer, dimension (:, :, :) :: k
+ logical :: l
+ integer :: p, q, r
+ character (len = n) :: s
+ integer, dimension (2, 3:5, n) :: t
+ integer, dimension (2, 3:n, n) :: u
+ character (len = n), dimension (5, 3:n) :: v
+ character (len = 2 * n + 24) :: w
+ integer :: x, z, z2
+ character (len = 1) :: y
+ s = 'PQRSTUV'
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!'
+ l = .false.
+ call omp_set_dynamic (.false.)
+ call omp_set_num_threads (6)
+!$omp parallel do default (none) lastprivate (c, d, e, f, g, h, i, j, k) &
+!$omp & lastprivate (s, t, u, v) reduction (.or.:l) num_threads (6) &
+!$omp private (p, q, r, w, x, y) schedule (static) shared (z2)
+ do 110 z = 0, omp_get_num_threads () - 1
+ if (omp_get_thread_num () .eq. 0) z2 = omp_get_num_threads ()
+ x = omp_get_thread_num ()
+ w = ''
+ if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
+ if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
+ if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
+ if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
+ if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
+ if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ c = w(8:19)
+ d = w(1:7)
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38)
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26)
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r
+ forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r
+ s = w(20:26)
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26)
+!$omp barrier
+ y = ''
+ if (x .eq. 0) y = '0'
+ if (x .eq. 1) y = '1'
+ if (x .eq. 2) y = '2'
+ if (x .eq. 3) y = '3'
+ if (x .eq. 4) y = '4'
+ if (x .eq. 5) y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 103, p = 1, 2
+ do 103, q = 3, 7
+ do 103, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+103 continue
+ do 104, p = 3, 5
+ do 104, q = 2, 6
+ do 104, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+104 continue
+ do 105, p = 1, 5
+ do 105, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+105 continue
+ call check (size (e, 1), 2, l)
+ call check (size (e, 2), 3, l)
+ call check (size (e, 3), 7, l)
+ call check (size (e), 42, l)
+ call check (size (f, 1), 2, l)
+ call check (size (f, 2), 5, l)
+ call check (size (f, 3), 7, l)
+ call check (size (f), 70, l)
+ call check (size (g, 1), 5, l)
+ call check (size (g, 2), 5, l)
+ call check (size (g), 25, l)
+ call check (size (h, 1), 5, l)
+ call check (size (h, 2), 5, l)
+ call check (size (h), 25, l)
+ call check (size (i, 1), 3, l)
+ call check (size (i, 2), 5, l)
+ call check (size (i, 3), 7, l)
+ call check (size (i), 105, l)
+ call check (size (j, 1), 4, l)
+ call check (size (j, 2), 5, l)
+ call check (size (j, 3), 7, l)
+ call check (size (j), 140, l)
+ call check (size (k, 1), 5, l)
+ call check (size (k, 2), 1, l)
+ call check (size (k, 3), 3, l)
+ call check (size (k), 15, l)
+110 continue
+!$omp end parallel do
+ if (l) call abort
+ if (z2 == 6) then
+ x = 5
+ w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 113, p = 1, 2
+ do 113, q = 3, 7
+ do 113, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+113 continue
+ do 114, p = 3, 5
+ do 114, q = 2, 6
+ do 114, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+114 continue
+ do 115, p = 1, 5
+ do 115, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+115 continue
+ if (l) call abort
+ end if
+ end subroutine foo
+
+ subroutine test
+ character (len = 12) :: c
+ character (len = 7) :: d
+ integer, dimension (2, 3:5, 7) :: e
+ integer, dimension (2, 3:7, 7) :: f
+ character (len = 12), dimension (5, 3:7) :: g
+ character (len = 7), dimension (5, 3:7) :: h
+ real, dimension (3:5, 2:6, 1:7) :: i
+ double precision, dimension (3:6, 2:6, 1:7) :: j
+ integer, dimension (1:5, 7:7, 4:6) :: k
+ integer :: p, q, r
+ c = 'abcdefghijkl'
+ d = 'ABCDEFG'
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY'
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456'
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543'
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r
+ forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r
+ call foo (c, d, e, f, g, h, i, j, k, 7)
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+
+ call test
+contains
+ subroutine check (x, y, l)
+ integer :: x, y
+ logical :: l
+ l = l .or. x .ne. y
+ end subroutine check
+
+ subroutine foo (c, d, e, f, g, h, i, j, k, n)
+ use omp_lib
+ integer :: n
+ character (len = *) :: c
+ character (len = n) :: d
+ integer, dimension (2, 3:5, n) :: e
+ integer, dimension (2, 3:n, n) :: f
+ character (len = *), dimension (5, 3:n) :: g
+ character (len = n), dimension (5, 3:n) :: h
+ real, dimension (:, :, :) :: i
+ double precision, dimension (3:, 5:, 7:) :: j
+ integer, dimension (:, :, :) :: k
+ logical :: l
+ integer :: p, q, r
+ character (len = n) :: s
+ integer, dimension (2, 3:5, n) :: t
+ integer, dimension (2, 3:n, n) :: u
+ character (len = n), dimension (5, 3:n) :: v
+ character (len = 2 * n + 24) :: w
+ integer :: x, z
+ character (len = 1) :: y
+ l = .false.
+!$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) &
+!$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) &
+!$omp private (p, q, r, w, x, y) shared (z)
+ x = omp_get_thread_num ()
+ w = ''
+ if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
+ if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
+ if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
+ if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
+ if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
+ if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ c = w(8:19)
+ d = w(1:7)
+ forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38)
+ forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26)
+ forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r
+ forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r
+ forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r
+ s = w(20:26)
+ forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r
+ forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r
+ forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7)
+ forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26)
+!$omp barrier
+ y = ''
+ if (x .eq. 0) y = '0'
+ if (x .eq. 1) y = '1'
+ if (x .eq. 2) y = '2'
+ if (x .eq. 3) y = '3'
+ if (x .eq. 4) y = '4'
+ if (x .eq. 5) y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 103, p = 1, 2
+ do 103, q = 3, 7
+ do 103, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+103 continue
+ do 104, p = 3, 5
+ do 104, q = 2, 6
+ do 104, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+104 continue
+ do 105, p = 1, 5
+ do 105, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+105 continue
+ call check (size (e, 1), 2, l)
+ call check (size (e, 2), 3, l)
+ call check (size (e, 3), 7, l)
+ call check (size (e), 42, l)
+ call check (size (f, 1), 2, l)
+ call check (size (f, 2), 5, l)
+ call check (size (f, 3), 7, l)
+ call check (size (f), 70, l)
+ call check (size (g, 1), 5, l)
+ call check (size (g, 2), 5, l)
+ call check (size (g), 25, l)
+ call check (size (h, 1), 5, l)
+ call check (size (h, 2), 5, l)
+ call check (size (h), 25, l)
+ call check (size (i, 1), 3, l)
+ call check (size (i, 2), 5, l)
+ call check (size (i, 3), 7, l)
+ call check (size (i), 105, l)
+ call check (size (j, 1), 4, l)
+ call check (size (j, 2), 5, l)
+ call check (size (j, 3), 7, l)
+ call check (size (j), 140, l)
+ call check (size (k, 1), 5, l)
+ call check (size (k, 2), 1, l)
+ call check (size (k, 3), 3, l)
+ call check (size (k), 15, l)
+!$omp single
+ z = omp_get_thread_num ()
+!$omp end single copyprivate (c, d, e, f, g, h, i, j, k, s, t, u, v)
+ w = ''
+ x = z
+ if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
+ if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
+ if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
+ if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
+ if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
+ if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
+ y = ''
+ if (x .eq. 0) y = '0'
+ if (x .eq. 1) y = '1'
+ if (x .eq. 2) y = '2'
+ if (x .eq. 3) y = '3'
+ if (x .eq. 4) y = '4'
+ if (x .eq. 5) y = '5'
+ l = l .or. w(7:7) .ne. y
+ l = l .or. w(19:19) .ne. y
+ l = l .or. w(26:26) .ne. y
+ l = l .or. w(38:38) .ne. y
+ l = l .or. c .ne. w(8:19)
+ l = l .or. d .ne. w(1:7)
+ l = l .or. s .ne. w(20:26)
+ do 113, p = 1, 2
+ do 113, q = 3, 7
+ do 113, r = 1, 7
+ if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
+ l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
+ if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
+ l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
+ if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
+ if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
+113 continue
+ do 114, p = 3, 5
+ do 114, q = 2, 6
+ do 114, r = 1, 7
+ l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
+ l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
+114 continue
+ do 115, p = 1, 5
+ do 115, q = 4, 6
+ l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
+115 continue
+!$omp end parallel
+ if (l) call abort
+ end subroutine foo
+
+ subroutine test
+ character (len = 12) :: c
+ character (len = 7) :: d
+ integer, dimension (2, 3:5, 7) :: e
+ integer, dimension (2, 3:7, 7) :: f
+ character (len = 12), dimension (5, 3:7) :: g
+ character (len = 7), dimension (5, 3:7) :: h
+ real, dimension (3:5, 2:6, 1:7) :: i
+ double precision, dimension (3:6, 2:6, 1:7) :: j
+ integer, dimension (1:5, 7:7, 4:6) :: k
+ integer :: p, q, r
+ call foo (c, d, e, f, g, h, i, j, k, 7)
+ end subroutine test
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-w" }
+
+ character (6) :: c, f2
+ character (6) :: d(2)
+ c = f1 (6)
+ if (c .ne. 'opqrst') call abort
+ c = f2 (6)
+ if (c .ne. '_/!!/_') call abort
+ d = f3 (6)
+ if (d(1) .ne. 'opqrst' .or. d(2) .ne. 'a') call abort
+ d = f4 (6)
+ if (d(1) .ne. 'Opqrst' .or. d(2) .ne. 'A') call abort
+contains
+ function f1 (n)
+ use omp_lib
+ character (n) :: f1
+ logical :: l
+ f1 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f1) reduction (.or.:l) num_threads (2)
+ l = f1 .ne. 'abcdef'
+ if (omp_get_thread_num () .eq. 0) f1 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f1 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 'IJKLMN')
+!$omp end parallel
+ f1 = 'zZzz_z'
+!$omp parallel shared (f1) reduction (.or.:l) num_threads (2)
+ l = l .or. f1 .ne. 'zZzz_z'
+!$omp barrier
+!$omp master
+ f1 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. f1 .ne. 'abc'
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f1 = 'def'
+!$omp barrier
+ l = l .or. f1 .ne. 'def'
+!$omp end parallel
+ if (l) call abort
+ f1 = 'opqrst'
+ end function f1
+ function f3 (n)
+ use omp_lib
+ character (n), dimension (2) :: f3
+ logical :: l
+ f3 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f3) reduction (.or.:l) num_threads (2)
+ l = any (f3 .ne. 'abcdef')
+ if (omp_get_thread_num () .eq. 0) f3 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f3 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f3 .ne. 'ijklmn'))
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f3 .ne. 'IJKLMN'))
+!$omp end parallel
+ f3 = 'zZzz_z'
+!$omp parallel shared (f3) reduction (.or.:l) num_threads (2)
+ l = l .or. any (f3 .ne. 'zZzz_z')
+!$omp barrier
+!$omp master
+ f3 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. any (f3 .ne. 'abc')
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f3 = 'def'
+!$omp barrier
+ l = l .or. any (f3 .ne. 'def')
+!$omp end parallel
+ if (l) call abort
+ f3(1) = 'opqrst'
+ f3(2) = 'a'
+ end function f3
+ function f4 (n)
+ use omp_lib
+ character (n), dimension (n - 4) :: f4
+ logical :: l
+ f4 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f4) reduction (.or.:l) num_threads (2)
+ l = any (f4 .ne. 'abcdef')
+ if (omp_get_thread_num () .eq. 0) f4 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f4 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f4 .ne. 'ijklmn'))
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f4 .ne. 'IJKLMN'))
+ l = l .or. size (f4) .ne. 2
+!$omp end parallel
+ f4 = 'zZzz_z'
+!$omp parallel shared (f4) reduction (.or.:l) num_threads (2)
+ l = l .or. any (f4 .ne. 'zZzz_z')
+!$omp barrier
+!$omp master
+ f4 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. any (f4 .ne. 'abc')
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f4 = 'def'
+!$omp barrier
+ l = l .or. any (f4 .ne. 'def')
+ l = l .or. size (f4) .ne. 2
+!$omp end parallel
+ if (l) call abort
+ f4(1) = 'Opqrst'
+ f4(2) = 'A'
+ end function f4
+end
+function f2 (n)
+ use omp_lib
+ character (*) :: f2
+ logical :: l
+ f2 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f2) reduction (.or.:l) num_threads (2)
+ l = f2 .ne. 'abcdef'
+ if (omp_get_thread_num () .eq. 0) f2 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f2 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f2 .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f2 .ne. 'IJKLMN')
+!$omp end parallel
+ f2 = 'zZzz_z'
+!$omp parallel shared (f2) reduction (.or.:l) num_threads (2)
+ l = l .or. f2 .ne. 'zZzz_z'
+!$omp barrier
+!$omp master
+ f2 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. f2 .ne. 'abc'
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f2 = 'def'
+!$omp barrier
+ l = l .or. f2 .ne. 'def'
+!$omp end parallel
+ if (l) call abort
+ f2 = '_/!!/_'
+end function f2
--- /dev/null
+function foo ()
+ integer :: foo
+ logical :: foo_seen
+ common /foo_seen/ foo_seen
+ foo_seen = .true.
+ foo = 3
+end
+function bar ()
+ integer :: bar
+ logical :: bar_seen
+ common /bar_seen/ bar_seen
+ bar_seen = .true.
+ bar = 3
+end
+ integer :: a (10), b (10), foo, bar
+ logical :: foo_seen, bar_seen
+ common /foo_seen/ foo_seen
+ common /bar_seen/ bar_seen
+
+ foo_seen = .false.
+ bar_seen = .false.
+!$omp parallel workshare if (foo () .gt. 2) num_threads (bar () + 1)
+ a = 10
+ b = 20
+ a(1:5) = max (a(1:5), b(1:5))
+!$omp end parallel workshare
+ if (any (a(1:5) .ne. 20)) call abort
+ if (any (a(6:10) .ne. 10)) call abort
+ if (.not. foo_seen .or. .not. bar_seen) call abort
+end
projects / gcc.git / commitdiff