This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH] Updated Cray Pointer Patch
- From: Asher Langton <langton2 at llnl dot gov>
- To: fortran at gcc dot gnu dot org
- Cc: gcc-patches at gcc dot gnu dot org
- Date: Mon, 10 Oct 2005 00:52:08 -0500
- Subject: [PATCH] Updated Cray Pointer Patch
Here's an updated Cray Pointer patch.
-Asher
2005-10-09 Asher Langton <langton2@llnl.gov>
PR fortran/17031
PR fortran/22282
* check.c (gfc_check_loc) : New function
* decl.c (variable_decl): New variables cp_as and sym. Added a
check for variables that have already been declared as Cray
Pointers, so we can get the necessary attributes without adding
a new symbol.
(attr_decl1): Added code to catch pointee symbols and "fix"
their array specs
(cray_pointer_decl): New method
(gfc_match_pointer): Added Cray pointer parsing code
(gfc_mod_pointee_as): New method
* expr.c (gfc_check_assign): added a check to catch vector-type
assignments to pointees with an unspecified final dimension.
* gfortran.h: (GFC_ISYM_LOC): New
(symbol_attribute): Added cray_pointer and cray_pointee bits
(gfc_array_spec): Added cray_pointee and cp_was_assumed bools
(gfc_symbol): Added gfc_symbol *cp_pointer
(gfc_option): Added flag_cray_pointer
(gfc_add_cray_pointee): Declare
(gfc_add_cray_pointer ): Declare
(gfc_mod_pointee_as): Declare
*gfortran.texi: Added section on Cray pointers, removed Cray
pointers from list of proposed extensions
* intrinsic.c (add_functions): add code for loc() intrinsic
* intrinsic.h (gfc_check_loc): Declare
(gfc_resolve_loc): Declare
* intrinsic.texi: Added documentation for loc intrinsic
* invoke.texi: Documented -fcray-pointer flag
* iresolve.c (gfc_resolve_loc): New
* lang.opt: Added fcray-pointer flag
* options.c (gfc_init_options): Intialized
gfc_match_option.flag_cray_pointer
(gfc_handle_option): deal with -fcray-pointer
* parse.c:(resolve_equivalence): Added code prohibiting Cray
pointees in equivalence statements.
* resolve.c (resolve_array_ref): added code to prevent bounds
checking for Cray Pointee arrays.
(resolve_equivalence): Prohibited pointees in equivalence
statements.
* symbol.c (check_conflict): Added Cray pointer/pointee
attribute checking
(gfc_add_cray_pointer): New
(gfc_add_cray_pointee): New
(gfc_copy_attr): New code for Cray pointers and pointees
* trans-array.c (gfc_trans_auto_array_allocation): added code to
prevent space from being allocated for pointees
(gfc_conv_array_parameter): added code to catch pointees and
correctly set their base address.
* trans-decl.c (gfc_finish_var_decl): added code to prevent
pointee declarations from making it to the back end.
(gfc_create_module_variable): same
* trans-expr.c (gfc_conv_variable): added code to detect and
translate pointees
(gfc_conv_cray_pointee): New
* trans-intrinsic.c (gfc_conv_intrinsic_loc): New
(gfc_conv_intrinsic_function): added entry point for loc
translation
* trans.h (gfc_conv_cray_pointee): Declare
2005-10-09 Asher Langton <langton2@llnl.gov>
PR fortran/17031
PR fortran/22282
*gfortran.dg/cray_pointers_1.f90: New
*gfortran.dg/cray_pointers_2.f90: New
*gfortran.dg/cray_pointers_3.f90: New
*gfortran.dg/loc_1.f90: New
*gfortran.dg/loc_2.f90: New
Index: check.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.34
diff -c -3 -p -r1.34 check.c
*** check.c 17 Sep 2005 18:57:59 -0000 1.34
--- check.c 10 Oct 2005 04:34:02 -0000
*************** gfc_check_link_sub (gfc_expr * path1, gf
*** 1194,1199 ****
--- 1194,1205 ----
return SUCCESS;
}
+ try
+ gfc_check_loc (gfc_expr *expr)
+ {
+ return variable_check (expr, 0);
+ }
+
try
gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
Index: decl.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/decl.c,v
retrieving revision 1.41
diff -c -3 -p -r1.41 decl.c
*** decl.c 25 Aug 2005 11:57:19 -0000 1.41
--- decl.c 10 Oct 2005 04:34:03 -0000
*************** variable_decl (void)
*** 905,917 ****
--- 905,920 ----
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *initializer, *char_len;
gfc_array_spec *as;
+ gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
gfc_charlen *cl;
locus var_locus;
match m;
try t;
+ gfc_symbol *sym;
initializer = NULL;
as = NULL;
+ cp_as = NULL;
/* When we get here, we've just matched a list of attributes and
maybe a type and a double colon. The next thing we expect to see
*************** variable_decl (void)
*** 924,930 ****
/* Now we could see the optional array spec. or character length. */
m = gfc_match_array_spec (&as);
! if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
--- 927,935 ----
/* Now we could see the optional array spec. or character length. */
m = gfc_match_array_spec (&as);
! if (gfc_option.flag_cray_pointer && m == MATCH_YES)
! cp_as = gfc_copy_array_spec (as);
! else if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
*************** variable_decl (void)
*** 953,958 ****
--- 958,1006 ----
}
}
+ /* If this symbol has already shown up in a Cray Pointer declaration,
+ then we want to set the type & bail out. */
+ if (gfc_option.flag_cray_pointer)
+ {
+ gfc_find_symbol (name, gfc_current_ns, 1, &sym);
+ if (sym != NULL && sym->attr.cray_pointee)
+ {
+ sym->ts.type = current_ts.type;
+ sym->ts.kind = current_ts.kind;
+ sym->ts.cl = cl;
+ sym->ts.derived = current_ts.derived;
+ m = MATCH_YES;
+
+ /* Check to see if we have an array specification. */
+ if (cp_as != NULL)
+ {
+ if (sym->as != NULL)
+ {
+ gfc_error ("Duplicate array spec for Cray pointee at %C.");
+ gfc_free_array_spec (cp_as);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ else
+ {
+ if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
+ gfc_internal_error ("Couldn't set pointee array spec.");
+
+ /* Fix the array spec. */
+ m = gfc_mod_pointee_as (sym->as);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
+ }
+ goto cleanup;
+ }
+ else
+ {
+ gfc_free_array_spec (cp_as);
+ }
+ }
+
+
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace, because it might be used in the
optional initialization expression for this symbol, e.g. this is
*************** attr_decl1 (void)
*** 2775,2780 ****
--- 2823,2836 ----
m = MATCH_ERROR;
goto cleanup;
}
+
+ if (sym->attr.cray_pointee && sym->as != NULL)
+ {
+ /* Fix the array spec. */
+ m = gfc_mod_pointee_as (sym->as);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
if ((current_attr.external || current_attr.intrinsic)
&& sym->attr.flavor != FL_PROCEDURE
*************** attr_decl (void)
*** 2828,2833 ****
--- 2884,3040 ----
}
+ /* This routine matches Cray Pointer declarations of the form:
+ pointer ( <pointer>, <pointee> )
+ or
+ pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
+ The pointer, if already declared, should be an integer. Otherwise, we
+ set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
+ be either a scalar, or an array declaration. No space is allocated for
+ the pointee. For the statement
+ pointer (ipt, ar(10))
+ any subsequent uses of ar will be translated (in C-notation) as
+ ar(i) => ((<type> *) ipt)(i)
+ By the time the code is translated into GENERIC, the pointee will
+ have disappeared from the code entirely. */
+
+ static match
+ cray_pointer_decl (void)
+ {
+ match m;
+ gfc_array_spec *as;
+ gfc_symbol *cptr; /* Pointer symbol. */
+ gfc_symbol *cpte; /* Pointee symbol. */
+ locus var_locus;
+ bool done = false;
+
+ while (!done)
+ {
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ gfc_error ("Expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Match pointer. */
+ var_locus = gfc_current_locus;
+ gfc_clear_attr (¤t_attr);
+ gfc_add_cray_pointer (¤t_attr, &var_locus);
+ current_ts.type = BT_INTEGER;
+ current_ts.kind = gfc_index_integer_kind;
+
+ m = gfc_match_symbol (&cptr, 0);
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Expected variable name at %C");
+ return m;
+ }
+
+ if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_set_sym_referenced (cptr);
+
+ if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
+ {
+ cptr->ts.type = BT_INTEGER;
+ cptr->ts.kind = gfc_index_integer_kind;
+ }
+ else if (cptr->ts.type != BT_INTEGER)
+ {
+ gfc_error ("Cray pointer at %C must be an integer.");
+ return MATCH_ERROR;
+ }
+ else if (cptr->ts.kind < gfc_index_integer_kind)
+ gfc_warning ("Cray pointer at %C has %d bytes of precision;"
+ " memory addresses require %d bytes.",
+ cptr->ts.kind,
+ gfc_index_integer_kind);
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Expected \",\" at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Match Pointee. */
+ var_locus = gfc_current_locus;
+ gfc_clear_attr (¤t_attr);
+ gfc_add_cray_pointee (¤t_attr, &var_locus);
+ current_ts.type = BT_UNKNOWN;
+ current_ts.kind = 0;
+
+ m = gfc_match_symbol (&cpte, 0);
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Expected variable name at %C");
+ return m;
+ }
+
+ /* Check for an optional array spec. */
+ m = gfc_match_array_spec (&as);
+ if (m == MATCH_ERROR)
+ {
+ gfc_free_array_spec (as);
+ return m;
+ }
+ else if (m == MATCH_NO)
+ {
+ gfc_free_array_spec (as);
+ as = NULL;
+ }
+
+ if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_set_sym_referenced (cpte);
+
+ if (cpte->as == NULL)
+ {
+ if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
+ gfc_internal_error ("Couldn't set Cray pointee array spec.");
+ }
+ else if (as != NULL)
+ {
+ gfc_error ("Duplicate array spec for Cray pointee at %C.");
+ gfc_free_array_spec (as);
+ return MATCH_ERROR;
+ }
+
+ as = NULL;
+
+ if (cpte->as != NULL)
+ {
+ /* Fix array spec. */
+ m = gfc_mod_pointee_as (cpte->as);
+ if (m == MATCH_ERROR)
+ return m;
+ }
+
+ /* Point the Pointee at the Pointer. */
+ cpte->cp_pointer=cptr;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ gfc_error ("Expected \")\" at %C");
+ return MATCH_ERROR;
+ }
+ m = gfc_match_char (',');
+ if (m != MATCH_YES)
+ done = true; /* Stop searching for more declarations. */
+
+ }
+
+ if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
+ || gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Expected \",\" or end of statement at %C");
+ return MATCH_ERROR;
+ }
+ return MATCH_YES;
+ }
+
+
match
gfc_match_external (void)
{
*************** gfc_match_optional (void)
*** 2881,2891 ****
match
gfc_match_pointer (void)
{
!
! gfc_clear_attr (¤t_attr);
! gfc_add_pointer (¤t_attr, NULL);
!
! return attr_decl ();
}
--- 3088,3111 ----
match
gfc_match_pointer (void)
{
! gfc_gobble_whitespace ();
! if (gfc_peek_char () == '(')
! {
! if (!gfc_option.flag_cray_pointer)
! {
! gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
! " flag.");
! return MATCH_ERROR;
! }
! return cray_pointer_decl ();
! }
! else
! {
! gfc_clear_attr (¤t_attr);
! gfc_add_pointer (¤t_attr, NULL);
!
! return attr_decl ();
! }
}
*************** loop:
*** 3388,3392 ****
--- 3608,3638 ----
gfc_new_block = sym;
+ return MATCH_YES;
+ }
+
+
+ /* Cray Pointees can be declared as:
+ pointer (ipt, a (n,m,...,*))
+ By default, this is treated as an AS_ASSUMED_SIZE array. We'll
+ cheat and set a constant bound of 1 for the last dimension, if this
+ is the case. Since there is no bounds-checking for Cray Pointees,
+ this will be okay. */
+
+ try
+ gfc_mod_pointee_as (gfc_array_spec *as)
+ {
+ as->cray_pointee = true; /* This will be useful to know later. */
+ if (as->type == AS_ASSUMED_SIZE)
+ {
+ as->type = AS_EXPLICIT;
+ as->upper[as->rank - 1] = gfc_int_expr (1);
+ as->cp_was_assumed = true;
+ }
+ else if (as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Cray Pointee at %C cannot be assumed shape array");
+ return MATCH_ERROR;
+ }
return MATCH_YES;
}
Index: expr.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.29
diff -c -3 -p -r1.29 expr.c
*** expr.c 17 Sep 2005 18:57:59 -0000 1.29
--- expr.c 10 Oct 2005 04:34:03 -0000
*************** gfc_check_assign (gfc_expr * lvalue, gfc
*** 1838,1843 ****
--- 1838,1853 ----
return FAILURE;
}
+ if (sym->attr.cray_pointee
+ && lvalue->ref != NULL
+ && lvalue->ref->u.ar.type != AR_ELEMENT
+ && lvalue->ref->u.ar.as->cp_was_assumed)
+ {
+ gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
+ " is illegal.", &lvalue->where);
+ return FAILURE;
+ }
+
/* This is possibly a typo: x = f() instead of x => f() */
if (gfc_option.warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION
Index: gfortran.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.88
diff -c -3 -p -r1.88 gfortran.h
*** gfortran.h 1 Oct 2005 07:39:04 -0000 1.88
--- gfortran.h 10 Oct 2005 04:34:03 -0000
*************** enum gfc_generic_isym_id
*** 351,356 ****
--- 351,357 ----
GFC_ISYM_LLE,
GFC_ISYM_LLT,
GFC_ISYM_LOG,
+ GFC_ISYM_LOC,
GFC_ISYM_LOG10,
GFC_ISYM_LOGICAL,
GFC_ISYM_MATMUL,
*************** typedef struct
*** 467,472 ****
--- 468,476 ----
ENUM_BITFIELD (ifsrc) if_source:2;
ENUM_BITFIELD (procedure_type) proc:3;
+
+ /* Special attributes for Cray pointers, pointees. */
+ unsigned cray_pointer:1, cray_pointee:1;
}
symbol_attribute;
*************** typedef struct
*** 564,569 ****
--- 568,580 ----
int rank; /* A rank of zero means that a variable is a scalar. */
array_type type;
struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
+
+ /* These two fields are used with the Cray Pointer extension. */
+ bool cray_pointee; /* True iff this spec belongs to a cray pointee. */
+ bool cp_was_assumed; /* AS_ASSUMED_SIZE cp arrays are converted to
+ AS_EXPLICIT, but we want to remember that we
+ did this. */
+
}
gfc_array_spec;
*************** typedef struct gfc_symbol
*** 708,713 ****
--- 719,727 ----
struct gfc_symbol *result; /* function result symbol */
gfc_component *components; /* Derived type components */
+ /* Defined only for Cray pointees; points to their pointer. */
+ struct gfc_symbol *cp_pointer;
+
struct gfc_symbol *common_next; /* Links for COMMON syms */
/* This is in fact a gfc_common_head but it is only used for pointer
*************** typedef struct
*** 1449,1454 ****
--- 1463,1469 ----
int flag_f2c;
int flag_automatic;
int flag_backslash;
+ int flag_cray_pointer;
int flag_d_lines;
int q_kind;
*************** try gfc_add_external (symbol_attribute *
*** 1631,1636 ****
--- 1646,1654 ----
try gfc_add_intrinsic (symbol_attribute *, locus *);
try gfc_add_optional (symbol_attribute *, locus *);
try gfc_add_pointer (symbol_attribute *, locus *);
+ try gfc_add_cray_pointer (symbol_attribute *, locus *);
+ try gfc_add_cray_pointee (symbol_attribute *, locus *);
+ 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_saved_common (symbol_attribute *, locus *);
Index: gfortran.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.texi,v
retrieving revision 1.24
diff -c -3 -p -r1.24 gfortran.texi
*** gfortran.texi 9 Sep 2005 19:20:52 -0000 1.24
--- gfortran.texi 10 Oct 2005 04:34:03 -0000
*************** Flag to generate @code{Makefile} info.
*** 491,499 ****
Automatically extend single precision constants to double.
@item
- Cray pointers (this was high on the @command{g77} wishlist).
-
- @item
Compile code that conserves memory by dynamically allocating common and
module storage either on stack or heap.
--- 491,496 ----
*************** of extensions, and @option{-std=legacy}
*** 633,638 ****
--- 630,636 ----
* Unary operators::
* Implicitly interconvert LOGICAL and INTEGER::
* Hollerith constants support::
+ * Cray pointers::
@end menu
@node Old-style kind specifications
*************** integer*4 a
*** 842,847 ****
--- 840,982 ----
a = 8H12345678 ! The Hollerith constant is too long. It will be truncated.
a = 0H ! At least one character needed.
@end smallexample
+
+ @node Cray pointers
+ @section Cray pointers
+ @cindex Cray pointers
+
+ Cray pointers are part of a non-standard extension that provides a
+ C-like pointer in Fortran. This is accomplished through a pair of
+ variables: an integer "pointer" that holds a memory address, and a
+ "pointee" that is used to dereference the pointer.
+
+ Pointer/pointee pairs are declared in statements of the form:
+ @smallexample
+ pointer ( <pointer> , <pointee> )
+ @end smallexample
+ or,
+ @smallexample
+ pointer ( <pointer1> , <pointee1> ), ( <pointer2> , <pointee2> ), ...
+ @end smallexample
+ The pointer is an integer that is intended to hold a memory address.
+ The pointee may be an array or scalar. A pointee can be an assumed
+ size array -- that is, the last dimension may be left unspecified by
+ using a '*' in place of a value -- but a pointee cannot be an assumed
+ shape array. No space is allocated for the pointee.
+
+ The pointee may have its type declared before or after the pointer
+ statement, and its array specification (if any) may be declared
+ before, during, or after the pointer statement. The pointer may be
+ declared as an integer prior to the pointer statement. However, some
+ machines have default integer sizes that are different than the size
+ of a pointer, and so the following code is not portable:
+ @smallexample
+ integer ipt
+ pointer (ipt, iarr)
+ @end smallexample
+ If a pointer is declared with a kind that is too small, the compiler
+ will issue a warning; the resulting binary will probably not work
+ correctly, because the memory addresses stored in the pointers may be
+ truncated. It is safer to omit the first line of the above example;
+ if explicit declaration of ipt's type is omitted, then the compiler
+ will ensure that ipt is an integer variable large enough to hold a
+ pointer.
+
+ Pointer arithmetic is valid with Cray pointers, but it is not the same
+ as C pointer arithmetic. Cray pointers are just ordinary integers, so
+ the user is responsible for determining how many bytes to add to a
+ pointer in order to increment it. Consider the following example:
+ @smallexample
+ real target(10)
+ real pointee(10)
+ pointer (ipt, pointee)
+ ipt = loc (target)
+ ipt = ipt + 1
+ @end smallexample
+ The last statement does not set ipt to the address of
+ @code{target(1)}, as one familiar with C pointer arithmetic might
+ expect. Adding 1 to ipt just adds one byte to the address stored in
+ ipt.
+
+ Any expression involving the pointee will be translated to use the
+ value stored in the pointer as the base address. This translation is
+ done in the front end, and so the pointees are not present in the
+ GENERIC tree that is handed off to the backend. One disadvantage of
+ this is that pointees will not appear in gdb when debugging a Fortran
+ program that uses Cray pointers.
+
+ To get the address of elements, this extension provides an intrinsic
+ function loc(), loc() is essentially the C '&' operator, except the
+ address is cast to an integer type:
+ @smallexample
+ real ar(10)
+ pointer(ipt, arpte(10))
+ real arpte
+ ipt = loc(ar) ! Makes arpte is an alias for ar
+ arpte(1) = 1.0 ! Sets ar(1) to 1.0
+ @end smallexample
+ The pointer can also be set by a call to a malloc-type
+ function. There is no malloc intrinsic implemented as part of the
+ Cray pointer extension, but it might be a useful future addition to
+ @command{gfortran}. Even without an intrinsic malloc function,
+ dynamic memory allocation can be combined with Cray pointers by
+ calling a short C function:
+ @smallexample
+ mymalloc.c:
+
+ void mymalloc_(void **ptr, int *nbytes)
+ @{
+ *ptr = malloc(*nbytes);
+ return;
+ @}
+
+ caller.f:
+
+ program caller
+ integer ipinfo;
+ real*4 data
+ pointer (ipdata, data(1024))
+ call mymalloc(ipdata,4*1024)
+ end
+ @end smallexample
+ Cray pointees often are used to alias an existing variable. For
+ example:
+ @smallexample
+ integer target(10)
+ integer iarr(10)
+ pointer (ipt, iarr)
+ ipt = loc(target)
+ @end smallexample
+ As long as ipt remains unchanged, iarr is now an alias for target.
+ The optimizer, however, will not detect this aliasing, so it is unsafe
+ to use iarr and target simultaneously. Using a pointee in any way
+ that violates the Fortran aliasing rules or assumptions is illegal.
+ It is the user's responsibility to avoid doing this; the compiler
+ works under the assumption that no such aliasing occurs.
+
+ Cray pointers will work correctly when there is no aliasing (i.e.,
+ when they're used to access a dynamically allocated block of memory),
+ and also in any routine where a pointee is used, but any variable with
+ which it shares storage is not used. Code that violates these rules
+ may not run as the user intends. This is not a bug in the optimizer;
+ any code that violates the aliasing rules is illegal. (Note that this
+ is not unique to gfortran; any Fortran compiler that supports Cray
+ pointers will ``incorrectly'' optimize code with illegal aliasing.)
+
+ There are a number of restrictions on the attributes that can be
+ applied to Cray pointers and pointees. Pointees may not have the
+ attributes ALLOCATABLE, INTENT, OPTIONAL, DUMMY, TARGET, EXTERNAL,
+ INTRINSIC, or POINTER. Pointers may not have the attributes
+ DIMENSION, POINTER, TARGET, ALLOCATABLE, EXTERNAL, or INTRINSIC.
+ Pointees may not occur in more than one pointer statement. A pointee
+ cannot be a pointer. Pointees cannot occur in equivalence, common, or
+ data statements.
+
+ A pointer may be modified during the course of a program, and this
+ will change the location to which the pointee refers. However, when
+ pointees are passed as arguments, they are treated as ordinary
+ variables in the invoked function. Subsequent changes to the pointer
+ will not change the base address of the array that was passed.
@include intrinsic.texi
@c ---------------------------------------------------------------------
Index: intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.55
diff -c -3 -p -r1.55 intrinsic.c
*** intrinsic.c 22 Sep 2005 19:00:22 -0000 1.55
--- intrinsic.c 10 Oct 2005 04:34:03 -0000
*************** add_functions (void)
*** 2098,2103 ****
--- 2098,2110 ----
bck, BT_LOGICAL, dl, OPTIONAL);
make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
+
+ add_sym_1 ("loc", 0, 1, BT_INTEGER, ii, GFC_STD_GNU,
+ gfc_check_loc, NULL, gfc_resolve_loc,
+ ar, BT_UNKNOWN, 0, REQUIRED);
+
+ make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
+
}
Index: intrinsic.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.33
diff -c -3 -p -r1.33 intrinsic.h
*** intrinsic.h 22 Sep 2005 19:00:23 -0000 1.33
--- intrinsic.h 10 Oct 2005 04:34:03 -0000
*************** try gfc_check_kill (gfc_expr *, gfc_expr
*** 77,82 ****
--- 77,83 ----
try gfc_check_kind (gfc_expr *);
try gfc_check_lbound (gfc_expr *, gfc_expr *);
try gfc_check_link (gfc_expr *, gfc_expr *);
+ try gfc_check_loc (gfc_expr *);
try gfc_check_logical (gfc_expr *, gfc_expr *);
try gfc_check_min_max (gfc_actual_arglist *);
try gfc_check_min_max_integer (gfc_actual_arglist *);
*************** void gfc_resolve_lbound (gfc_expr *, gfc
*** 327,332 ****
--- 328,334 ----
void gfc_resolve_len (gfc_expr *, gfc_expr *);
void gfc_resolve_len_trim (gfc_expr *, gfc_expr *);
void gfc_resolve_link (gfc_expr *, gfc_expr *, gfc_expr *);
+ void gfc_resolve_loc (gfc_expr *, gfc_expr *);
void gfc_resolve_log (gfc_expr *, gfc_expr *);
void gfc_resolve_log10 (gfc_expr *, gfc_expr *);
void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *);
Index: intrinsic.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.texi,v
retrieving revision 1.17
diff -c -3 -p -r1.17 intrinsic.texi
*** intrinsic.texi 22 Sep 2005 19:00:23 -0000 1.17
--- intrinsic.texi 10 Oct 2005 04:34:03 -0000
*************** and editing. All contributions and corr
*** 87,92 ****
--- 87,93 ----
* @code{EXPONENT}: EXPONENT, Exponent function
* @code{FLOOR}: FLOOR, Integer floor function
* @code{FNUM}: FNUM, File number function
+ * @code{LOC}: LOC, Returns the address of a variable
* @code{LOG}: LOG, Logarithm function
* @code{LOG10}: LOG10, Base 10 logarithm function
* @code{REAL}: REAL, Convert to real type
*************** end program test_fnum
*** 2724,2730 ****
--- 2725,2767 ----
@end smallexample
@end table
+ @node LOC
+ @section @code{LOC} --- Returns the address of a variable
+ @findex @code{LOC} intrinsic
+ @cindex loc
+ @table @asis
+ @item @emph{Description}:
+ @code{LOC(X)} returns the address of @var{X} as an integer.
+
+ @item @emph{Option}:
+ gnu
+
+ @item @emph{Class}:
+ inquiry function
+
+ @item @emph{Syntax}:
+ @code{I = LOC(X)}
+
+ @item @emph{Arguments}:
+ @multitable @columnfractions .15 .80
+ @item @var{X} @tab Variable of any type.
+ @end multitable
+
+ @item @emph{Return value}:
+ The return value is of type @code{INTEGER(n)}, where @code{n} is the
+ size (in bytes) of a memory address on the target machine.
+
+ @item @emph{Example}:
+ @smallexample
+ program test_loc
+ integer :: i
+ real :: r
+ i = loc(r)
+ print *, i
+ end program test_loc
+ @end smallexample
+ @end table
@node LOG
@section @code{LOG} --- Logarithm function
Index: invoke.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/invoke.texi,v
retrieving revision 1.21
diff -c -3 -p -r1.21 invoke.texi
*** invoke.texi 31 Aug 2005 12:31:30 -0000 1.21
--- invoke.texi 10 Oct 2005 04:34:03 -0000
*************** by type. Explanations are in the follow
*** 119,125 ****
-fdollar-ok -fimplicit-none -fmax-identifier-length @gol
-std=@var{std} -fd-lines-as-code -fd-lines-as-comments @gol
-ffixed-line-length-@var{n} -ffixed-line-length-none @gol
! -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 }
@item Warning Options
@xref{Warning Options,,Options to Request or Suppress Warnings}.
--- 119,126 ----
-fdollar-ok -fimplicit-none -fmax-identifier-length @gol
-std=@var{std} -fd-lines-as-code -fd-lines-as-comments @gol
-ffixed-line-length-@var{n} -ffixed-line-length-none @gol
! -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol
! -fcray-pointer }
@item Warning Options
@xref{Warning Options,,Options to Request or Suppress Warnings}.
*************** Specify the maximum allowed identifier l
*** 264,269 ****
--- 265,275 ----
Specify that no implicit typing is allowed, unless overridden by explicit
@samp{IMPLICIT} statements. This is the equivalent of adding
@samp{implicit none} to the start of every procedure.
+
+ @cindex -fcray-pointer option
+ @cindex options, -fcray-pointer
+ @item -fcray-pointer
+ Enables the Cray pointer extension, which provides a C-like pointer.
@cindex -std=@var{std} option
@cindex option, -std=@var{std}
Index: iresolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.41
diff -c -3 -p -r1.41 iresolve.c
*** iresolve.c 3 Oct 2005 07:22:18 -0000 1.41
--- iresolve.c 10 Oct 2005 04:34:03 -0000
*************** gfc_resolve_link (gfc_expr * f, gfc_expr
*** 839,844 ****
--- 839,853 ----
void
+ gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
+ {
+ f->ts.type= BT_INTEGER;
+ f->ts.kind = gfc_index_integer_kind;
+ f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
+ }
+
+
+ void
gfc_resolve_log (gfc_expr * f, gfc_expr * x)
{
f->ts = x->ts;
Index: lang.opt
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/lang.opt,v
retrieving revision 1.19
diff -c -3 -p -r1.19 lang.opt
*** lang.opt 13 Sep 2005 06:24:18 -0000 1.19
--- lang.opt 10 Oct 2005 04:34:03 -0000
*************** funderscoring
*** 121,126 ****
--- 121,130 ----
Fortran
Append underscores to externally visible names
+ fcray-pointer
+ Fortran
+ Use the Cray Pointer extension
+
fsecond-underscore
Fortran
Append a second underscore if the name already contains an underscore
Index: options.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/options.c,v
retrieving revision 1.26
diff -c -3 -p -r1.26 options.c
*** options.c 26 Sep 2005 20:06:36 -0000 1.26
--- options.c 10 Oct 2005 04:34:03 -0000
*************** gfc_init_options (unsigned int argc ATTR
*** 72,77 ****
--- 72,78 ----
gfc_option.flag_repack_arrays = 0;
gfc_option.flag_automatic = 1;
gfc_option.flag_backslash = 1;
+ gfc_option.flag_cray_pointer = 0;
gfc_option.flag_d_lines = -1;
gfc_option.q_kind = gfc_default_double_kind;
*************** gfc_handle_option (size_t scode, const c
*** 326,331 ****
--- 327,336 ----
case OPT_Wunused_labels:
gfc_option.warn_unused_labels = value;
+ break;
+
+ case OPT_fcray_pointer:
+ gfc_option.flag_cray_pointer = value;
break;
case OPT_ff2c:
Index: resolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.58
diff -c -3 -p -r1.58 resolve.c
*** resolve.c 6 Oct 2005 15:44:01 -0000 1.58
--- resolve.c 10 Oct 2005 04:34:03 -0000
*************** resolve_array_ref (gfc_array_ref * ar)
*** 2000,2006 ****
}
}
! if (compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
return SUCCESS;
--- 2000,2006 ----
}
}
! if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
return SUCCESS;
*************** resolve_equivalence (gfc_equiv *eq)
*** 5082,5087 ****
--- 5082,5095 ----
"object in the pure procedure '%s'",
sym->name, &e->where, sym->ns->proc_name->name);
break;
+ }
+
+ /* Shall not be a Cray pointee. */
+ if (sym->attr.cray_pointee)
+ {
+ gfc_error ("Cray Pointee '%s' at %L cannot be an EQUIVALENCE "
+ "object", sym->name, &e->where);
+ continue;
}
/* Shall not be a named constant. */
Index: symbol.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/symbol.c,v
retrieving revision 1.36
diff -c -3 -p -r1.36 symbol.c
*** symbol.c 1 Oct 2005 07:39:05 -0000 1.36
--- symbol.c 10 Oct 2005 04:34:03 -0000
*************** check_conflict (symbol_attribute * attr,
*** 263,269 ****
*public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
! *use_assoc = "USE ASSOCIATED";
const char *a1, *a2;
--- 263,270 ----
*public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
! *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
! *cray_pointee = "CRAY POINTEE";
const char *a1, *a2;
*************** check_conflict (symbol_attribute * attr,
*** 340,345 ****
--- 341,371 ----
conf (function, subroutine);
+ /* Cray pointer/pointee conflicts. */
+ conf (cray_pointer, cray_pointee);
+ conf (cray_pointer, dimension);
+ conf (cray_pointer, pointer);
+ conf (cray_pointer, target);
+ conf (cray_pointer, allocatable);
+ conf (cray_pointer, external);
+ conf (cray_pointer, intrinsic);
+ conf (cray_pointer, in_namelist);
+ conf (cray_pointer, function);
+ conf (cray_pointer, subroutine);
+ conf (cray_pointer, entry);
+
+ conf (cray_pointee, allocatable);
+ conf (cray_pointee, intent);
+ conf (cray_pointee, optional);
+ conf (cray_pointee, dummy);
+ conf (cray_pointee, target);
+ conf (cray_pointee, external);
+ conf (cray_pointee, intrinsic);
+ conf (cray_pointee, pointer);
+ conf (cray_pointee, function);
+ conf (cray_pointee, subroutine);
+ conf (cray_pointee, entry);
+
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
*************** gfc_add_pointer (symbol_attribute * attr
*** 650,655 ****
--- 676,712 ----
try
+ gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
+ {
+
+ if (check_used (attr, NULL, where) || check_done (attr, where))
+ return FAILURE;
+
+ attr->cray_pointer = 1;
+ return check_conflict (attr, NULL, where);
+ }
+
+
+ try
+ gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
+ {
+
+ if (check_used (attr, NULL, where) || check_done (attr, where))
+ return FAILURE;
+
+ if (attr->cray_pointee)
+ {
+ gfc_error ("Cray Pointee at %L appears in multiple pointer()"
+ " statements.", where);
+ return FAILURE;
+ }
+
+ attr->cray_pointee = 1;
+ return check_conflict (attr, NULL, where);
+ }
+
+
+ try
gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
{
*************** gfc_copy_attr (symbol_attribute * dest,
*** 1143,1148 ****
--- 1200,1210 ----
if (gfc_missing_attr (dest, where) == FAILURE)
goto fail;
+ if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
+ goto fail;
+ if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
+ goto fail;
+
/* The subroutines that set these bits also cause flavors to be set,
and that has already happened in the original, so don't let it
happen again. */
Index: trans-array.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.63
diff -c -3 -p -r1.63 trans-array.c
*** trans-array.c 14 Sep 2005 05:12:00 -0000 1.63
--- trans-array.c 10 Oct 2005 04:34:04 -0000
*************** gfc_trans_auto_array_allocation (tree de
*** 3240,3245 ****
--- 3240,3254 ----
size = gfc_trans_array_bounds (type, sym, &offset, &block);
+ /* Don't actually allocate space for Cray Pointees. */
+ if (sym->attr.cray_pointee)
+ {
+ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+ gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_expr_to_block (&block, fnbody);
+ return gfc_finish_block (&block);
+ }
+
/* The size is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 4074,4080 ****
&& expr->ref->u.ar.type == AR_FULL && g77)
{
sym = expr->symtree->n.sym;
! tmp = gfc_get_symbol_decl (sym);
if (sym->ts.type == BT_CHARACTER)
se->string_length = sym->ts.cl->backend_decl;
if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
--- 4083,4095 ----
&& expr->ref->u.ar.type == AR_FULL && g77)
{
sym = expr->symtree->n.sym;
!
! /* Check to see if we're dealing with a Cray Pointee. */
! if (sym->attr.cray_pointee)
! tmp = gfc_conv_cray_pointee (sym);
! else
! tmp = gfc_get_symbol_decl (sym);
!
if (sym->ts.type == BT_CHARACTER)
se->string_length = sym->ts.cl->backend_decl;
if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
*************** gfc_walk_expr (gfc_expr * expr)
*** 4625,4628 ****
res = gfc_walk_subexpr (gfc_ss_terminator, expr);
return gfc_reverse_ss (res);
}
-
--- 4640,4642 ----
Index: trans-decl.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.70
diff -c -3 -p -r1.70 trans-decl.c
*** trans-decl.c 3 Oct 2005 07:22:18 -0000 1.70
--- trans-decl.c 10 Oct 2005 04:34:04 -0000
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 415,420 ****
--- 415,425 ----
This is the equivalent of the TARGET variables.
We also need to set this if the variable is passed by reference in a
CALL statement. */
+
+ /* We don't want real declarations for Cray Pointees. */
+ if (sym->attr.cray_pointee)
+ return;
+
if (sym->attr.target)
TREE_ADDRESSABLE (decl) = 1;
/* If it wasn't used we wouldn't be getting it. */
*************** gfc_create_module_variable (gfc_symbol *
*** 2245,2250 ****
--- 2250,2259 ----
/* Create the decl. */
decl = gfc_get_symbol_decl (sym);
+ /* Don't create a "real" declaration for a Cray Pointee. */
+ if (sym->attr.cray_pointee)
+ return;
+
/* Create the variable. */
pushdecl (decl);
rest_of_decl_compilation (decl, 1, 0);
*************** gfc_generate_block_data (gfc_namespace *
*** 2649,2654 ****
--- 2658,2695 ----
pushdecl (decl);
rest_of_decl_compilation (decl, 1, 0);
+ }
+
+ /* gfc_conv_cray_pointee takes a sym with attribute cray_pointee and
+ swaps in the backend_decl of its corresponding pointer. There are
+ 2 cases; one for variable size arrays, and one for everything else,
+ because variable-sized arrays require one fewer level of
+ indirection. */
+
+ tree
+ gfc_conv_cray_pointee(gfc_symbol *sym)
+ {
+ tree decl = gfc_get_symbol_decl (sym->cp_pointer);
+
+ /* Parameters need to be dereferenced. */
+ if (sym->cp_pointer->attr.dummy)
+ decl = gfc_build_indirect_ref (decl);
+
+ /* Check to see if we're dealing with a variable-sized array. */
+ if (sym->attr.dimension
+ && TREE_CODE (TREE_TYPE (sym->backend_decl)) == POINTER_TYPE)
+ {
+ /* These decls will be derefenced later, so we don't dereference
+ them here. */
+ decl = convert (TREE_TYPE (sym->backend_decl), decl);
+ }
+ else
+ {
+ decl = convert (build_pointer_type (TREE_TYPE (sym->backend_decl)),
+ decl);
+ decl = gfc_build_indirect_ref (decl);
+ }
+ return decl;
}
#include "gt-fortran-trans-decl.h"
Index: trans-expr.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.65
diff -c -3 -p -r1.65 trans-expr.c
*** trans-expr.c 3 Oct 2005 07:22:18 -0000 1.65
--- trans-expr.c 10 Oct 2005 04:34:04 -0000
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 316,322 ****
{
tree se_expr = NULL_TREE;
! se->expr = gfc_get_symbol_decl (sym);
/* Special case for assigning the return value of a function.
Self recursive functions must have an explicit return value. */
--- 316,326 ----
{
tree se_expr = NULL_TREE;
! /* Handle Cray Pointees. */
! if (sym->attr.cray_pointee)
! se->expr = gfc_conv_cray_pointee (sym);
! else
! se->expr = gfc_get_symbol_decl (sym);
/* Special case for assigning the return value of a function.
Self recursive functions must have an explicit return value. */
Index: trans-intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.55
diff -c -3 -p -r1.55 trans-intrinsic.c
*** trans-intrinsic.c 3 Oct 2005 07:22:18 -0000 1.55
--- trans-intrinsic.c 10 Oct 2005 04:34:04 -0000
*************** gfc_conv_intrinsic_iargc (gfc_se * se, g
*** 2739,2744 ****
--- 2739,2774 ----
se->expr = tmp;
}
+
+ /* The loc intrinsic returns the address of its argument as
+ gfc_index_integer_kind integer. */
+
+ static void
+ gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
+ {
+ tree temp_var;
+ gfc_expr *arg_expr;
+ gfc_ss *ss;
+
+ gcc_assert (!se->ss);
+
+ arg_expr = expr->value.function.actual->expr;
+ ss = gfc_walk_expr (arg_expr);
+ if (ss == gfc_ss_terminator)
+ gfc_conv_expr_reference (se, arg_expr);
+ else
+ gfc_conv_array_parameter (se, arg_expr, ss, 1);
+ se->expr= convert (gfc_unsigned_type (long_integer_type_node),
+ se->expr);
+
+ /* Create a temporary variable for loc return value. Without this,
+ we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
+ temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node),
+ NULL);
+ gfc_add_modify_expr (&se->pre, temp_var, se->expr);
+ se->expr = temp_var;
+ }
+
/* Generate code for an intrinsic function. Some map directly to library
calls, others get special handling. In some cases the name of the function
used depends on the type specifiers. */
*************** gfc_conv_intrinsic_function (gfc_se * se
*** 3045,3050 ****
--- 3075,3084 ----
case GFC_ISYM_UBOUND:
gfc_conv_intrinsic_bound (se, expr, 1);
+ break;
+
+ case GFC_ISYM_LOC:
+ gfc_conv_intrinsic_loc (se, expr);
break;
case GFC_ISYM_CHDIR:
Index: trans.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans.h,v
retrieving revision 1.36
diff -c -3 -p -r1.36 trans.h
*** trans.h 3 Oct 2005 07:22:18 -0000 1.36
--- trans.h 10 Oct 2005 04:34:04 -0000
*************** void gfc_generate_block_data (gfc_namesp
*** 406,411 ****
--- 406,414 ----
/* Output a decl for a module variable. */
void gfc_generate_module_vars (gfc_namespace *);
+ /* Translate the declaration for a Cray Pointee. */
+ tree gfc_conv_cray_pointee (gfc_symbol *sym);
+
/* Get and set the current location. */
void gfc_set_backend_locus (locus *);
void gfc_get_backend_locus (locus *);
! { dg-do run }
! This test is here to prevent a regression in gfc_conv_intrinsic_loc.
! Taking the loc of something in a common block was a special case
! that caused in internal compiler error in gcc/expr.c, in
! expand_expr_addr_expr_1().
program test
common /targ/targ
integer targ(10)
call fn
end program test
subroutine fn
common /targ/targ
integer targ(10)
call foo (loc (targ)) ! Line that caused ICE
end subroutine fn
subroutine foo (ii)
common /targ/targ
integer targ(10)
integer ii
targ(2) = ii
end subroutine foo
! { dg-do run }
! Series of routines for testing a loc() implementation
program test
common /errors/errors(12)
integer i
logical errors
errors = .false.
call testloc
do i=1,12
if (errors(i)) then
call abort()
endif
end do
end program test
! Test loc
subroutine testloc
common /errors/errors(12)
logical errors
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer :: offset
integer :: i,j,k,intsize,realsize,dblsize,chsize,ch8size
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
intsize = kind(itarg1(1))
realsize = kind(rtarg1(1))
chsize = kind(chtarg1(1))*len(chtarg1(1))
ch8size = kind(ch8targ1(1))*len(ch8targ1(1))
do, i=1,n
offset = i-1
if (loc(itarg1).ne.loc(itarg1(i))-offset*intsize) then
! Error #1
errors(1) = .true.
end if
if (loc(rtarg1).ne.loc(rtarg1(i))-offset*realsize) then
! Error #2
errors(2) = .true.
end if
if (loc(chtarg1).ne.loc(chtarg1(i))-offset*chsize) then
! Error #3
errors(3) = .true.
end if
if (loc(ch8targ1).ne.loc(ch8targ1(i))-offset*ch8size) then
! Error #4
errors(4) = .true.
end if
do, j=1,m
offset = (j-1)+m*(i-1)
if (loc(itarg2).ne. &
loc(itarg2(j,i))-offset*intsize) then
! Error #5
errors(5) = .true.
end if
if (loc(rtarg2).ne. &
loc(rtarg2(j,i))-offset*realsize) then
! Error #6
errors(6) = .true.
end if
if (loc(chtarg2).ne. &
loc(chtarg2(j,i))-offset*chsize) then
! Error #7
errors(7) = .true.
end if
if (loc(ch8targ2).ne. &
loc(ch8targ2(j,i))-offset*ch8size) then
! Error #8
errors(8) = .true.
end if
do k=1,o
offset = (k-1)+o*(j-1)+o*m*(i-1)
if (loc(itarg3).ne. &
loc(itarg3(k,j,i))-offset*intsize) then
! Error #9
errors(9) = .true.
end if
if (loc(rtarg3).ne. &
loc(rtarg3(k,j,i))-offset*realsize) then
! Error #10
errors(10) = .true.
end if
if (loc(chtarg3).ne. &
loc(chtarg3(k,j,i))-offset*chsize) then
! Error #11
errors(11) = .true.
end if
if (loc(ch8targ3).ne. &
loc(ch8targ3(k,j,i))-offset*ch8size) then
! Error #12
errors(12) = .true.
end if
end do
end do
end do
end subroutine testloc
! { dg-do compile }
! { dg-options "-fcray-pointer" }
! Bad type for pointer
subroutine err1
real ipt
real array(10)
pointer (ipt, array) ! { dg-error "integer" }
end subroutine err1
! Multiple declarations for the same pointee
subroutine err2
real array(10)
pointer (ipt1, array)
pointer (ipt2, array) ! { dg-error "multiple" }
end subroutine err2
! Vector assignment to an assumed size array
subroutine err3
real target(10)
real array(*)
pointer (ipt, array)
ipt = loc (target)
array = 0 ! { dg-error "Vector assignment" }
end subroutine err3
subroutine err4
pointer (ipt, ipt) ! { dg-error "POINTER attribute" }
end subroutine err4
! duplicate array specs
subroutine err5
pointer (ipt, array(7))
real array(10) ! { dg-error "Duplicate array" }
end subroutine err5
subroutine err6
real array(10)
pointer (ipt, array(7)) ! { dg-error "Duplicate array" }
end subroutine err6
! parsing stuff
subroutine err7
pointer ( ! { dg-error "variable name" }
pointer (ipt ! { dg-error "Expected" }
pointer (ipt, ! { dg-error "variable name" }
pointer (ipt,a1 ! { dg-error "Expected" }
pointer (ipt,a2), ! { dg-error "Expected" }
pointer (ipt,a3),( ! { dg-error "variable name" }
pointer (ipt,a4),(ipt2 ! { dg-error "Expected" }
pointer (ipt,a5),(ipt2, ! { dg-error "variable name" }
pointer (ipt,a6),(ipt2,a7 ! { dg-error "Expected" }
end subroutine err7
! more attributes
subroutine err8(array)
real array(10)
integer dim(2)
integer, pointer :: f90ptr
integer, target :: f90targ
pointer (ipt, array) ! { dg-error "DUMMY" }
pointer (dim, elt1) ! { dg-error "DIMENSION" }
pointer (f90ptr, elt2) ! { dg-error "POINTER" }
pointer (ipt, f90ptr) ! { dg-error "POINTER" }
pointer (f90targ, elt3) ! { dg-error "TARGET" }
pointer (ipt, f90targ) ! { dg-error "TARGET" }
end subroutine err8
! { dg-do run }
! { dg-options "-fcray-pointer" }
! Series of routines for testing a Cray pointer implementation
program craytest
common /errors/errors(400)
common /foo/foo ! To prevent optimizations
integer foo
integer i
logical errors
errors = .false.
foo = 0
call ptr1
call ptr2
call ptr3
call ptr4
call ptr5
call ptr6
call ptr7
call ptr8
call ptr9(9,10,11)
call ptr10(9,10,11)
call ptr11(9,10,11)
call ptr12(9,10,11)
call ptr13(9,10)
call parmtest
! NOTE: Tests 1 through 12 were removed from this file
! and placed in loc_1.f90, so we start at 13
do i=13,400
if (errors(i)) then
! print *,"Test",i,"failed."
call abort()
endif
end do
if (foo.eq.0) then
! print *,"Test did not run correctly."
call abort()
endif
end program craytest
! ptr1 through ptr13 that Cray pointees are correctly used with
! a variety of declaration styles
subroutine ptr1
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
type(drvd) dpte1(n)
type(drvd) dpte2(m,n)
type(drvd) dpte3(o,m,n)
integer ipte1 (n)
integer ipte2 (m,n)
integer ipte3 (o,m,n)
real rpte1(n)
real rpte2(m,n)
real rpte3(o,m,n)
character chpte1(n)
character chpte2(m,n)
character chpte3(o,m,n)
character*8 ch8pte1(n)
character*8 ch8pte2(m,n)
character*8 ch8pte3(o,m,n)
pointer(iptr1,dpte1)
pointer(iptr2,dpte2)
pointer(iptr3,dpte3)
pointer(iptr4,ipte1)
pointer(iptr5,ipte2)
pointer(iptr6,ipte3)
pointer(iptr7,rpte1)
pointer(iptr8,rpte2)
pointer(iptr9,rpte3)
pointer(iptr10,chpte1)
pointer(iptr11,chpte2)
pointer(iptr12,chpte3)
pointer(iptr13,ch8pte1)
pointer(iptr14,ch8pte2)
pointer(iptr15,ch8pte3)
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #13
errors(13) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #14
errors(14) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #15
errors(15) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #16
errors(16) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #17
errors(17) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #18
errors(18) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #19
errors(19) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #20
errors(20) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #21
errors(21) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #22
errors(22) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #23
errors(23) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #24
errors(24) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #25
errors(25) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #26
errors(26) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #27
errors(27) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #28
errors(28) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #29
errors(29) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #30
errors(30) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #31
errors(31) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #32
errors(32) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #33
errors(33) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #34
errors(34) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #35
errors(35) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #36
errors(36) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #37
errors(37) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #38
errors(38) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #39
errors(39) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #40
errors(40) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #41
errors(41) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #42
errors(42) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #43
errors(43) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #44
errors(44) = .true.
endif
end do
end do
end do
end subroutine ptr1
subroutine ptr2
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
type(drvd) dpte1
type(drvd) dpte2
type(drvd) dpte3
integer ipte1
integer ipte2
integer ipte3
real rpte1
real rpte2
real rpte3
character chpte1
character chpte2
character chpte3
character*8 ch8pte1
character*8 ch8pte2
character*8 ch8pte3
pointer(iptr1,dpte1(n))
pointer(iptr2,dpte2(m,n))
pointer(iptr3,dpte3(o,m,n))
pointer(iptr4,ipte1(n))
pointer(iptr5,ipte2 (m,n))
pointer(iptr6,ipte3(o,m,n))
pointer(iptr7,rpte1(n))
pointer(iptr8,rpte2(m,n))
pointer(iptr9,rpte3(o,m,n))
pointer(iptr10,chpte1(n))
pointer(iptr11,chpte2(m,n))
pointer(iptr12,chpte3(o,m,n))
pointer(iptr13,ch8pte1(n))
pointer(iptr14,ch8pte2(m,n))
pointer(iptr15,ch8pte3(o,m,n))
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #45
errors(45) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #46
errors(46) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #47
errors(47) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #48
errors(48) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #49
errors(49) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #50
errors(50) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #51
errors(51) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #52
errors(52) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #53
errors(53) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #54
errors(54) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #55
errors(55) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #56
errors(56) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #57
errors(57) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #58
errors(58) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #59
errors(59) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #60
errors(60) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #61
errors(61) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #62
errors(62) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #63
errors(63) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #64
errors(64) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #65
errors(65) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #66
errors(66) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #67
errors(67) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #68
errors(68) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #69
errors(69) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #70
errors(70) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #71
errors(71) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #72
errors(72) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #73
errors(73) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #74
errors(74) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #75
errors(75) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #76
errors(76) = .true.
endif
end do
end do
end do
end subroutine ptr2
subroutine ptr3
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
pointer(iptr1,dpte1(n))
pointer(iptr2,dpte2(m,n))
pointer(iptr3,dpte3(o,m,n))
pointer(iptr4,ipte1(n))
pointer(iptr5,ipte2 (m,n))
pointer(iptr6,ipte3(o,m,n))
pointer(iptr7,rpte1(n))
pointer(iptr8,rpte2(m,n))
pointer(iptr9,rpte3(o,m,n))
pointer(iptr10,chpte1(n))
pointer(iptr11,chpte2(m,n))
pointer(iptr12,chpte3(o,m,n))
pointer(iptr13,ch8pte1(n))
pointer(iptr14,ch8pte2(m,n))
pointer(iptr15,ch8pte3(o,m,n))
type(drvd) dpte1
type(drvd) dpte2
type(drvd) dpte3
integer ipte1
integer ipte2
integer ipte3
real rpte1
real rpte2
real rpte3
character chpte1
character chpte2
character chpte3
character*8 ch8pte1
character*8 ch8pte2
character*8 ch8pte3
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #77
errors(77) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #78
errors(78) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #79
errors(79) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #80
errors(80) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #81
errors(81) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #82
errors(82) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #83
errors(83) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #84
errors(84) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #85
errors(85) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #86
errors(86) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #87
errors(87) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #88
errors(88) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #89
errors(89) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #90
errors(90) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #91
errors(91) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #92
errors(92) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #93
errors(93) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #94
errors(94) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #95
errors(95) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #96
errors(96) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #97
errors(97) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #98
errors(98) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #99
errors(99) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #100
errors(100) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #101
errors(101) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #102
errors(102) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #103
errors(103) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #104
errors(104) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #105
errors(105) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #106
errors(106) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #107
errors(107) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #108
errors(108) = .true.
endif
end do
end do
end do
end subroutine ptr3
subroutine ptr4
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
pointer(iptr1,dpte1),(iptr2,dpte2),(iptr3,dpte3)
pointer (iptr4,ipte1), (iptr5,ipte2) ,(iptr6,ipte3),(iptr7,rpte1)
pointer(iptr8,rpte2)
pointer(iptr9,rpte3),(iptr10,chpte1)
pointer(iptr11,chpte2),(iptr12,chpte3),(iptr13,ch8pte1)
pointer(iptr14,ch8pte2)
pointer(iptr15,ch8pte3)
type(drvd) dpte1(n)
type(drvd) dpte2(m,n)
type(drvd) dpte3(o,m,n)
integer ipte1 (n)
integer ipte2 (m,n)
integer ipte3 (o,m,n)
real rpte1(n)
real rpte2(m,n)
real rpte3(o,m,n)
character chpte1(n)
character chpte2(m,n)
character chpte3(o,m,n)
character*8 ch8pte1(n)
character*8 ch8pte2(m,n)
character*8 ch8pte3(o,m,n)
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #109
errors(109) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #110
errors(110) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #111
errors(111) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #112
errors(112) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #113
errors(113) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #114
errors(114) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #115
errors(115) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #116
errors(116) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #117
errors(117) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #118
errors(118) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #119
errors(119) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #120
errors(120) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #121
errors(121) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #122
errors(122) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #123
errors(123) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #124
errors(124) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #125
errors(125) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #126
errors(126) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #127
errors(127) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #128
errors(128) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #129
errors(129) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #130
errors(130) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #131
errors(131) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #132
errors(132) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #133
errors(133) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #134
errors(134) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #135
errors(135) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #136
errors(136) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #137
errors(137) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #138
errors(138) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #139
errors(139) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #140
errors(140) = .true.
endif
end do
end do
end do
end subroutine ptr4
subroutine ptr5
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
type(drvd) dpte1(*)
type(drvd) dpte2(m,*)
type(drvd) dpte3(o,m,*)
integer ipte1 (*)
integer ipte2 (m,*)
integer ipte3 (o,m,*)
real rpte1(*)
real rpte2(m,*)
real rpte3(o,m,*)
character chpte1(*)
character chpte2(m,*)
character chpte3(o,m,*)
character*8 ch8pte1(*)
character*8 ch8pte2(m,*)
character*8 ch8pte3(o,m,*)
pointer(iptr1,dpte1)
pointer(iptr2,dpte2)
pointer(iptr3,dpte3)
pointer(iptr4,ipte1)
pointer(iptr5,ipte2)
pointer(iptr6,ipte3)
pointer(iptr7,rpte1)
pointer(iptr8,rpte2)
pointer(iptr9,rpte3)
pointer(iptr10,chpte1)
pointer(iptr11,chpte2)
pointer(iptr12,chpte3)
pointer(iptr13,ch8pte1)
pointer(iptr14,ch8pte2)
pointer(iptr15,ch8pte3)
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #141
errors(141) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #142
errors(142) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #143
errors(143) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #144
errors(144) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #145
errors(145) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #146
errors(146) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #147
errors(147) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #148
errors(148) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #149
errors(149) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #150
errors(150) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #151
errors(151) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #152
errors(152) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #153
errors(153) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #154
errors(154) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #155
errors(155) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #156
errors(156) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #157
errors(157) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #158
errors(158) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #159
errors(159) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #160
errors(160) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #161
errors(161) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #162
errors(162) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #163
errors(163) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #164
errors(164) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #165
errors(165) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #166
errors(166) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #167
errors(167) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #168
errors(168) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #169
errors(169) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #170
errors(170) = .true.
endif
end do
end do
end do
end subroutine ptr5
subroutine ptr6
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
type(drvd) dpte1
type(drvd) dpte2
type(drvd) dpte3
integer ipte1
integer ipte2
integer ipte3
real rpte1
real rpte2
real rpte3
character chpte1
character chpte2
character chpte3
character*8 ch8pte1
character*8 ch8pte2
character*8 ch8pte3
pointer(iptr1,dpte1(*))
pointer(iptr2,dpte2(m,*))
pointer(iptr3,dpte3(o,m,*))
pointer(iptr4,ipte1(*))
pointer(iptr5,ipte2 (m,*))
pointer(iptr6,ipte3(o,m,*))
pointer(iptr7,rpte1(*))
pointer(iptr8,rpte2(m,*))
pointer(iptr9,rpte3(o,m,*))
pointer(iptr10,chpte1(*))
pointer(iptr11,chpte2(m,*))
pointer(iptr12,chpte3(o,m,*))
pointer(iptr13,ch8pte1(*))
pointer(iptr14,ch8pte2(m,*))
pointer(iptr15,ch8pte3(o,m,*))
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #171
errors(171) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #172
errors(172) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #173
errors(173) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #174
errors(174) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #175
errors(175) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #176
errors(176) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #177
errors(177) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #178
errors(178) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #179
errors(179) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #180
errors(180) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #181
errors(181) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #182
errors(182) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #183
errors(183) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #184
errors(184) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #185
errors(185) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #186
errors(186) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #187
errors(187) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #188
errors(188) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #189
errors(189) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #190
errors(190) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #191
errors(191) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #192
errors(192) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #193
errors(193) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #194
errors(194) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #195
errors(195) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #196
errors(196) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #197
errors(197) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #198
errors(198) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #199
errors(199) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #200
errors(200) = .true.
endif
end do
end do
end do
end subroutine ptr6
subroutine ptr7
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
pointer(iptr1,dpte1(*))
pointer(iptr2,dpte2(m,*))
pointer(iptr3,dpte3(o,m,*))
pointer(iptr4,ipte1(*))
pointer(iptr5,ipte2 (m,*))
pointer(iptr6,ipte3(o,m,*))
pointer(iptr7,rpte1(*))
pointer(iptr8,rpte2(m,*))
pointer(iptr9,rpte3(o,m,*))
pointer(iptr10,chpte1(*))
pointer(iptr11,chpte2(m,*))
pointer(iptr12,chpte3(o,m,*))
pointer(iptr13,ch8pte1(*))
pointer(iptr14,ch8pte2(m,*))
pointer(iptr15,ch8pte3(o,m,*))
type(drvd) dpte1
type(drvd) dpte2
type(drvd) dpte3
integer ipte1
integer ipte2
integer ipte3
real rpte1
real rpte2
real rpte3
character chpte1
character chpte2
character chpte3
character*8 ch8pte1
character*8 ch8pte2
character*8 ch8pte3
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #201
errors(201) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #202
errors(202) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #203
errors(203) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #204
errors(204) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #205
errors(205) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #206
errors(206) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #207
errors(207) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #208
errors(208) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #209
errors(209) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #210
errors(210) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #211
errors(211) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #212
errors(212) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #213
errors(213) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #214
errors(214) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #215
errors(215) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #216
errors(216) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #217
errors(217) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #218
errors(218) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #219
errors(219) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #220
errors(220) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #221
errors(221) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #222
errors(222) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #223
errors(223) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #224
errors(224) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #225
errors(225) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #226
errors(226) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #227
errors(227) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #228
errors(228) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #229
errors(229) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #230
errors(230) = .true.
endif
end do
end do
end do
end subroutine ptr7
subroutine ptr8
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
pointer(iptr1,dpte1)
pointer(iptr2,dpte2)
pointer(iptr3,dpte3)
pointer(iptr4,ipte1)
pointer(iptr5,ipte2)
pointer(iptr6,ipte3)
pointer(iptr7,rpte1)
pointer(iptr8,rpte2)
pointer(iptr9,rpte3)
pointer(iptr10,chpte1)
pointer(iptr11,chpte2)
pointer(iptr12,chpte3)
pointer(iptr13,ch8pte1)
pointer(iptr14,ch8pte2)
pointer(iptr15,ch8pte3)
type(drvd) dpte1(*)
type(drvd) dpte2(m,*)
type(drvd) dpte3(o,m,*)
integer ipte1 (*)
integer ipte2 (m,*)
integer ipte3 (o,m,*)
real rpte1(*)
real rpte2(m,*)
real rpte3(o,m,*)
character chpte1(*)
character chpte2(m,*)
character chpte3(o,m,*)
character*8 ch8pte1(*)
character*8 ch8pte2(m,*)
character*8 ch8pte3(o,m,*)
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #231
errors(231) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #232
errors(232) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #233
errors(233) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #234
errors(234) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #235
errors(235) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #236
errors(236) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #237
errors(237) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #238
errors(238) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #239
errors(239) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #240
errors(240) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #241
errors(241) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #242
errors(242) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #243
errors(243) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #244
errors(244) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #245
errors(245) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #246
errors(246) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #247
errors(247) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #248
errors(248) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #249
errors(249) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #250
errors(250) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #251
errors(251) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #252
errors(252) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #253
errors(253) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #254
errors(254) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #255
errors(255) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #256
errors(256) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #257
errors(257) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #258
errors(258) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #259
errors(259) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #260
errors(260) = .true.
endif
end do
end do
end do
end subroutine ptr8
subroutine ptr9(nnn,mmm,ooo)
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer :: nnn,mmm,ooo
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
type(drvd) dpte1(nnn)
type(drvd) dpte2(mmm,nnn)
type(drvd) dpte3(ooo,mmm,nnn)
integer ipte1 (nnn)
integer ipte2 (mmm,nnn)
integer ipte3 (ooo,mmm,nnn)
real rpte1(nnn)
real rpte2(mmm,nnn)
real rpte3(ooo,mmm,nnn)
character chpte1(nnn)
character chpte2(mmm,nnn)
character chpte3(ooo,mmm,nnn)
character*8 ch8pte1(nnn)
character*8 ch8pte2(mmm,nnn)
character*8 ch8pte3(ooo,mmm,nnn)
pointer(iptr1,dpte1)
pointer(iptr2,dpte2)
pointer(iptr3,dpte3)
pointer(iptr4,ipte1)
pointer(iptr5,ipte2)
pointer(iptr6,ipte3)
pointer(iptr7,rpte1)
pointer(iptr8,rpte2)
pointer(iptr9,rpte3)
pointer(iptr10,chpte1)
pointer(iptr11,chpte2)
pointer(iptr12,chpte3)
pointer(iptr13,ch8pte1)
pointer(iptr14,ch8pte2)
pointer(iptr15,ch8pte3)
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #261
errors(261) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #262
errors(262) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #263
errors(263) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #264
errors(264) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #265
errors(265) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #266
errors(266) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #267
errors(267) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #268
errors(268) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #269
errors(269) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #270
errors(270) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #271
errors(271) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #272
errors(272) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #273
errors(273) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #274
errors(274) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #275
errors(275) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #276
errors(276) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #277
errors(277) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #278
errors(278) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #279
errors(279) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #280
errors(280) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #281
errors(281) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #282
errors(282) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #283
errors(283) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #284
errors(284) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #285
errors(285) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #286
errors(286) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #287
errors(287) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #288
errors(288) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #289
errors(289) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #290
errors(290) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #291
errors(291) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #292
errors(292) = .true.
endif
end do
end do
end do
end subroutine ptr9
subroutine ptr10(nnn,mmm,ooo)
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer :: nnn,mmm,ooo
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
type(drvd) dpte1
type(drvd) dpte2
type(drvd) dpte3
integer ipte1
integer ipte2
integer ipte3
real rpte1
real rpte2
real rpte3
character chpte1
character chpte2
character chpte3
character*8 ch8pte1
character*8 ch8pte2
character*8 ch8pte3
pointer(iptr1,dpte1(nnn))
pointer(iptr2,dpte2(mmm,nnn))
pointer(iptr3,dpte3(ooo,mmm,nnn))
pointer(iptr4,ipte1(nnn))
pointer(iptr5,ipte2 (mmm,nnn))
pointer(iptr6,ipte3(ooo,mmm,nnn))
pointer(iptr7,rpte1(nnn))
pointer(iptr8,rpte2(mmm,nnn))
pointer(iptr9,rpte3(ooo,mmm,nnn))
pointer(iptr10,chpte1(nnn))
pointer(iptr11,chpte2(mmm,nnn))
pointer(iptr12,chpte3(ooo,mmm,nnn))
pointer(iptr13,ch8pte1(nnn))
pointer(iptr14,ch8pte2(mmm,nnn))
pointer(iptr15,ch8pte3(ooo,mmm,nnn))
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #293
errors(293) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #294
errors(294) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #295
errors(295) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #296
errors(296) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #297
errors(297) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #298
errors(298) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #299
errors(299) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #300
errors(300) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #301
errors(301) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #302
errors(302) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #303
errors(303) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #304
errors(304) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #305
errors(305) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #306
errors(306) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #307
errors(307) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #308
errors(308) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #309
errors(309) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #310
errors(310) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #311
errors(311) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #312
errors(312) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #313
errors(313) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #314
errors(314) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #315
errors(315) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #316
errors(316) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #317
errors(317) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #318
errors(318) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #319
errors(319) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #320
errors(320) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #321
errors(321) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #322
errors(322) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #323
errors(323) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #324
errors(324) = .true.
endif
end do
end do
end do
end subroutine ptr10
subroutine ptr11(nnn,mmm,ooo)
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer :: nnn,mmm,ooo
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
pointer(iptr1,dpte1(nnn))
pointer(iptr2,dpte2(mmm,nnn))
pointer(iptr3,dpte3(ooo,mmm,nnn))
pointer(iptr4,ipte1(nnn))
pointer(iptr5,ipte2 (mmm,nnn))
pointer(iptr6,ipte3(ooo,mmm,nnn))
pointer(iptr7,rpte1(nnn))
pointer(iptr8,rpte2(mmm,nnn))
pointer(iptr9,rpte3(ooo,mmm,nnn))
pointer(iptr10,chpte1(nnn))
pointer(iptr11,chpte2(mmm,nnn))
pointer(iptr12,chpte3(ooo,mmm,nnn))
pointer(iptr13,ch8pte1(nnn))
pointer(iptr14,ch8pte2(mmm,nnn))
pointer(iptr15,ch8pte3(ooo,mmm,nnn))
type(drvd) dpte1
type(drvd) dpte2
type(drvd) dpte3
integer ipte1
integer ipte2
integer ipte3
real rpte1
real rpte2
real rpte3
character chpte1
character chpte2
character chpte3
character*8 ch8pte1
character*8 ch8pte2
character*8 ch8pte3
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #325
errors(325) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #326
errors(326) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #327
errors(327) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #328
errors(328) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #329
errors(329) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #330
errors(330) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #331
errors(331) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #332
errors(332) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #333
errors(333) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #334
errors(334) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #335
errors(335) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #336
errors(336) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #337
errors(337) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #338
errors(338) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #339
errors(339) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #340
errors(340) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #341
errors(341) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #342
errors(342) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #343
errors(343) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #344
errors(344) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #345
errors(345) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #346
errors(346) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #347
errors(347) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #348
errors(348) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #349
errors(349) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #350
errors(350) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #351
errors(351) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #352
errors(352) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #353
errors(353) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #354
errors(354) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #355
errors(355) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #356
errors(356) = .true.
endif
end do
end do
end do
end subroutine ptr11
subroutine ptr12(nnn,mmm,ooo)
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: i,j,k
integer :: nnn,mmm,ooo
integer, parameter :: n = 9
integer, parameter :: m = 10
integer, parameter :: o = 11
integer itarg1 (n)
integer itarg2 (m,n)
integer itarg3 (o,m,n)
real rtarg1(n)
real rtarg2(m,n)
real rtarg3(o,m,n)
character chtarg1(n)
character chtarg2(m,n)
character chtarg3(o,m,n)
character*8 ch8targ1(n)
character*8 ch8targ2(m,n)
character*8 ch8targ3(o,m,n)
type drvd
real r1
integer i1
integer i2(5)
end type drvd
type(drvd) dtarg1(n)
type(drvd) dtarg2(m,n)
type(drvd) dtarg3(o,m,n)
pointer(iptr1,dpte1)
pointer(iptr2,dpte2)
pointer(iptr3,dpte3)
pointer(iptr4,ipte1)
pointer(iptr5,ipte2)
pointer(iptr6,ipte3)
pointer(iptr7,rpte1)
pointer(iptr8,rpte2)
pointer(iptr9,rpte3)
pointer(iptr10,chpte1)
pointer(iptr11,chpte2)
pointer(iptr12,chpte3)
pointer(iptr13,ch8pte1)
pointer(iptr14,ch8pte2)
pointer(iptr15,ch8pte3)
type(drvd) dpte1(nnn)
type(drvd) dpte2(mmm,nnn)
type(drvd) dpte3(ooo,mmm,nnn)
integer ipte1 (nnn)
integer ipte2 (mmm,nnn)
integer ipte3 (ooo,mmm,nnn)
real rpte1(nnn)
real rpte2(mmm,nnn)
real rpte3(ooo,mmm,nnn)
character chpte1(nnn)
character chpte2(mmm,nnn)
character chpte3(ooo,mmm,nnn)
character*8 ch8pte1(nnn)
character*8 ch8pte2(mmm,nnn)
character*8 ch8pte3(ooo,mmm,nnn)
iptr1 = loc(dtarg1)
iptr2 = loc(dtarg2)
iptr3 = loc(dtarg3)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr6 = loc(itarg3)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
iptr9 = loc(rtarg3)
iptr10= loc(chtarg1)
iptr11= loc(chtarg2)
iptr12= loc(chtarg3)
iptr13= loc(ch8targ1)
iptr14= loc(ch8targ2)
iptr15= loc(ch8targ3)
do, i=1,n
dpte1(i)%i1=i
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #357
errors(357) = .true.
endif
dtarg1(i)%i1=2*dpte1(i)%i1
if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
! Error #358
errors(358) = .true.
endif
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #359
errors(359) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #360
errors(360) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #361
errors(361) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #362
errors(362) = .true.
endif
chpte1(i) = 'a'
if (chne(chpte1(i), chtarg1(i))) then
! Error #363
errors(363) = .true.
endif
chtarg1(i) = 'z'
if (chne(chpte1(i), chtarg1(i))) then
! Error #364
errors(364) = .true.
endif
ch8pte1(i) = 'aaaaaaaa'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #365
errors(365) = .true.
endif
ch8targ1(i) = 'zzzzzzzz'
if (ch8ne(ch8pte1(i), ch8targ1(i))) then
! Error #366
errors(366) = .true.
endif
do, j=1,m
dpte2(j,i)%r1=1.0
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #367
errors(367) = .true.
endif
dtarg2(j,i)%r1=2*dpte2(j,i)%r1
if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
! Error #368
errors(368) = .true.
endif
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #369
errors(369) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #370
errors(370) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #371
errors(371) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #372
errors(372) = .true.
endif
chpte2(j,i) = 'a'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #373
errors(373) = .true.
endif
chtarg2(j,i) = 'z'
if (chne(chpte2(j,i), chtarg2(j,i))) then
! Error #374
errors(374) = .true.
endif
ch8pte2(j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #375
errors(375) = .true.
endif
ch8targ2(j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
! Error #376
errors(376) = .true.
endif
do k=1,o
dpte3(k,j,i)%i2(1+mod(i,5))=i
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #377
errors(377) = .true.
endif
dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
dtarg3(k,j,i)%i2(1+mod(i,5)))) then
! Error #378
errors(378) = .true.
endif
ipte3(k,j,i) = i
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #379
errors(379) = .true.
endif
itarg3(k,j,i) = -ipte3(k,j,i)
if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
! Error #380
errors(380) = .true.
endif
rpte3(k,j,i) = i * 2.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #381
errors(381) = .true.
endif
rtarg3(k,j,i) = i * 3.0
if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
! Error #382
errors(382) = .true.
endif
chpte3(k,j,i) = 'a'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #383
errors(383) = .true.
endif
chtarg3(k,j,i) = 'z'
if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
! Error #384
errors(384) = .true.
endif
ch8pte3(k,j,i) = 'aaaaaaaa'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #385
errors(385) = .true.
endif
ch8targ3(k,j,i) = 'zzzzzzzz'
if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
! Error #386
errors(386) = .true.
endif
end do
end do
end do
rtarg3 = .5
! Vector syntax
do, i=1,n
ipte3 = i
rpte3 = rpte3+1
do, j=1,m
do k=1,o
if (intne(itarg3(k,j,i), i)) then
! Error #387
errors(387) = .true.
endif
if (realne(rtarg3(k,j,i), i+.5)) then
! Error #388
errors(388) = .true.
endif
end do
end do
end do
end subroutine ptr12
! Misc
subroutine ptr13(nnn,mmm)
common /errors/errors(400)
logical :: errors, intne, realne, chne, ch8ne
integer :: nnn,mmm
integer :: i,j
integer, parameter :: n = 9
integer, parameter :: m = 10
integer itarg1 (n)
integer itarg2 (m,n)
real rtarg1(n)
real rtarg2(m,n)
integer ipte1
integer ipte2
real rpte1
real rpte2
dimension ipte1(n)
dimension rpte2(mmm,nnn)
pointer(iptr4,ipte1)
pointer(iptr5,ipte2)
pointer(iptr7,rpte1)
pointer(iptr8,rpte2)
dimension ipte2(mmm,nnn)
dimension rpte1(n)
iptr4 = loc(itarg1)
iptr5 = loc(itarg2)
iptr7 = loc(rtarg1)
iptr8 = loc(rtarg2)
do, i=1,n
ipte1(i) = i
if (intne(ipte1(i), itarg1(i))) then
! Error #389
errors(389) = .true.
endif
itarg1(i) = -ipte1(i)
if (intne(ipte1(i), itarg1(i))) then
! Error #390
errors(390) = .true.
endif
rpte1(i) = i * 5.0
if (realne(rpte1(i), rtarg1(i))) then
! Error #391
errors(391) = .true.
endif
rtarg1(i) = i * (-5.0)
if (realne(rpte1(i), rtarg1(i))) then
! Error #392
errors(392) = .true.
endif
do, j=1,m
ipte2(j,i) = i
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #393
errors(393) = .true.
endif
itarg2(j,i) = -ipte2(j,i)
if (intne(ipte2(j,i), itarg2(j,i))) then
! Error #394
errors(394) = .true.
endif
rpte2(j,i) = i * (-2.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #395
errors(395) = .true.
endif
rtarg2(j,i) = i * (-3.0)
if (realne(rpte2(j,i), rtarg2(j,i))) then
! Error #396
errors(396) = .true.
endif
end do
end do
end subroutine ptr13
! Test the passing of pointers and pointees as parameters
subroutine parmtest
integer, parameter :: n = 12
integer, parameter :: m = 13
integer iarray(m,n)
pointer (ipt,iptee)
integer iptee (m,n)
ipt = loc(iarray)
! write(*,*) "loc(iarray)",loc(iarray)
call parmptr(ipt,iarray,n,m)
! write(*,*) "loc(iptee)",loc(iptee)
call parmpte(iptee,iarray,n,m)
end subroutine parmtest
subroutine parmptr(ipointer,intarr,n,m)
common /errors/errors(400)
logical :: errors, intne
integer :: n,m,i,j
integer intarr(m,n)
pointer (ipointer,newpte)
integer newpte(m,n)
! write(*,*) "loc(newpte)",loc(newpte)
! write(*,*) "loc(intarr)",loc(intarr)
! write(*,*) "loc(newpte(1,1))",loc(newpte(1,1))
! newpte(1,1) = 101
! write(*,*) "newpte(1,1)=",newpte(1,1)
! write(*,*) "intarr(1,1)=",intarr(1,1)
do, i=1,n
do, j=1,m
newpte(j,i) = i
if (intne(newpte(j,i),intarr(j,i))) then
! Error #397
errors(397) = .true.
endif
call donothing(newpte(j,i),intarr(j,i))
intarr(j,i) = -newpte(j,i)
if (intne(newpte(j,i),intarr(j,i))) then
! Error #398
errors(398) = .true.
endif
end do
end do
end subroutine parmptr
subroutine parmpte(pointee,intarr,n,m)
common /errors/errors(400)
logical :: errors, intne
integer :: n,m,i,j
integer pointee (m,n)
integer intarr (m,n)
! write(*,*) "loc(pointee)",loc(pointee)
! write(*,*) "loc(intarr)",loc(intarr)
! write(*,*) "loc(pointee(1,1))",loc(pointee(1,1))
! pointee(1,1) = 99
! write(*,*) "pointee(1,1)=",pointee(1,1)
! write(*,*) "intarr(1,1)=",intarr(1,1)
do, i=1,n
do, j=1,m
pointee(j,i) = i
if (intne(pointee(j,i),intarr(j,i))) then
! Error #399
errors(399) = .true.
endif
intarr(j,i) = 2*pointee(j,i)
call donothing(pointee(j,i),intarr(j,i))
if (intne(pointee(j,i),intarr(j,i))) then
! Error #400
errors(400) = .true.
endif
end do
end do
end subroutine parmpte
! Separate function calls to break Cray pointer-indifferent optimization
logical function intne(ii,jj)
integer :: i,j
common /foo/foo
integer foo
foo = foo + 1
intne = ii.ne.jj
if (intne) then
write (*,*) ii," doesn't equal ",jj
endif
end function intne
logical function realne(r1,r2)
real :: r1, r2
common /foo/foo
integer foo
foo = foo + 1
realne = r1.ne.r2
if (realne) then
write (*,*) r1," doesn't equal ",r2
endif
end function realne
logical function chne(ch1,ch2)
character :: ch1, ch2
common /foo/foo
integer foo
foo = foo + 1
chne = ch1.ne.ch2
if (chne) then
write (*,*) ch1," doesn't equal ",ch2
endif
end function chne
logical function ch8ne(ch1,ch2)
character*8 :: ch1, ch2
common /foo/foo
integer foo
foo = foo + 1
ch8ne = ch1.ne.ch2
if (ch8ne) then
write (*,*) ch1," doesn't equal ",ch2
endif
end function ch8ne
subroutine donothing(ii,jj)
common/foo/foo
integer :: ii,jj,foo
if (foo.le.1) then
foo = 1
else
foo = foo - 1
endif
if (foo.eq.0) then
ii = -1
jj = 1
! print *,"Test did not run correctly"
call abort()
endif
end subroutine donothing
! { dg-do compile }
program crayerr
real dpte1(10)
pointer (iptr1,dpte1) ! { dg-error "fcray-pointer" }
end program crayerr