This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR64771 - Fix coarray ICE
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc-patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>, Alessandro Fanfarillo <fanfarillo dot gcc at gmail dot com>
- Date: Sat, 24 Jan 2015 18:13:04 +0100
- Subject: [Patch, Fortran] PR64771 - Fix coarray ICE
- Authentication-results: sourceware.org; auth=none
Build and regtested on x86-64-gnu-linux.
OK for the trunk and 4.9? (It's a regression.)
Tobias
2015-01-24 Tobias Burnus <burnus@net-b.de>
PR fortran/64771
gcc/fortran/
* interface.c (check_dummy_characteristics): Fix coarray handling.
testsuite/
* gfortran.dg/coarray_36.f: New.
* gfortran.dg/coarray_37.f90: New.
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index dd3ad2a..5de416b 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1205,8 +1205,15 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
return false;
}
+ if (s1->as->corank != s2->as->corank)
+ {
+ snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)",
+ s1->name, s1->as->corank, s2->as->corank);
+ return false;
+ }
+
if (s1->as->type == AS_EXPLICIT)
- for (i = 0; i < s1->as->rank + s1->as->corank; i++)
+ for (i = 0; i < s1->as->rank + std::max(0, s1->as->corank-1); i++)
{
shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
gfc_copy_expr (s1->as->lower[i]));
@@ -1220,8 +1227,12 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -1:
case 1:
case -3:
- snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
- "argument '%s'", i + 1, s1->name);
+ if (i < s1->as->rank)
+ snprintf (errmsg, err_len, "Shape mismatch in dimension %i of"
+ " argument '%s'", i + 1, s1->name);
+ else
+ snprintf (errmsg, err_len, "Shape mismatch in codimension %i "
+ "of argument '%s'", i - s1->as->rank + 1, s1->name);
return false;
case -2:
diff --git a/gcc/testsuite/gfortran.dg/coarray_36.f b/gcc/testsuite/gfortran.dg/coarray_36.f
new file mode 100644
index 0000000..d06a01e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_36.f
@@ -0,0 +1,347 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+!
+! PR fortran/64771
+!
+! Contributed by Alessandro Fanfarill
+!
+! Reduced version of the full NAS CG benchmark
+!
+
+!-------------------------------------------------------------------------!
+! !
+! N A S P A R A L L E L B E N C H M A R K S 3.3 !
+! !
+! C G !
+! !
+!-------------------------------------------------------------------------!
+! !
+! This benchmark is part of the NAS Parallel Benchmark 3.3 suite. !
+! It is described in NAS Technical Reports 95-020 and 02-007 !
+! !
+! Permission to use, copy, distribute and modify this software !
+! for any purpose with or without fee is hereby granted. We !
+! request, however, that all derived work reference the NAS !
+! Parallel Benchmarks 3.3. This software is provided "as is" !
+! without express or implied warranty. !
+! !
+! Information on NPB 3.3, including the technical report, the !
+! original specifications, source code, results and information !
+! on how to submit new results, is available at: !
+! !
+! http://www.nas.nasa.gov/Software/NPB/ !
+! !
+! Send comments or suggestions to npb@nas.nasa.gov !
+! !
+! NAS Parallel Benchmarks Group !
+! NASA Ames Research Center !
+! Mail Stop: T27A-1 !
+! Moffett Field, CA 94035-1000 !
+! !
+! E-mail: npb@nas.nasa.gov !
+! Fax: (650) 604-3957 !
+! !
+!-------------------------------------------------------------------------!
+
+
+c---------------------------------------------------------------------
+c
+c Authors: M. Yarrow
+c C. Kuszmaul
+c R. F. Van der Wijngaart
+c H. Jin
+c
+c---------------------------------------------------------------------
+
+
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+ program cg
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+ implicit none
+
+ integer na, nonzer, niter
+ double precision shift, rcond
+ parameter( na=75000,
+ > nonzer=13,
+ > niter=75,
+ > shift=60.,
+ > rcond=1.0d-1 )
+
+
+
+ integer num_proc_rows, num_proc_cols
+ parameter( num_proc_rows = 2, num_proc_cols = 2)
+ integer num_procs
+ parameter( num_procs = num_proc_cols * num_proc_rows )
+
+ integer nz
+ parameter( nz = na*(nonzer+1)/num_procs*(nonzer+1)+nonzer
+ > + na*(nonzer+2+num_procs/256)/num_proc_cols )
+
+ common / partit_size / naa, nzz,
+ > npcols, nprows,
+ > proc_col, proc_row,
+ > firstrow,
+ > lastrow,
+ > firstcol,
+ > lastcol,
+ > exch_proc,
+ > exch_recv_length,
+ > send_start,
+ > send_len
+ integer naa, nzz,
+ > npcols, nprows,
+ > proc_col, proc_row,
+ > firstrow,
+ > lastrow,
+ > firstcol,
+ > lastcol,
+ > exch_proc,
+ > exch_recv_length,
+ > send_start,
+ > send_len
+
+
+ common / main_int_mem / colidx, rowstr,
+ > iv, arow, acol
+ integer colidx(nz), rowstr(na+1),
+ > iv(2*na+1), arow(nz), acol(nz)
+
+
+c---------------------------------
+c Coarray Decalarations
+c---------------------------------
+ double precision v(na+1)[0:*], aelt(nz)[0:*], a(nz)[0:*],
+ > x(na/num_proc_rows+2)[0:*],
+ > z(na/num_proc_rows+2)[0:*],
+ > p(na/num_proc_rows+2)[0:*],
+ > q(na/num_proc_rows+2)[0:*],
+ > r(na/num_proc_rows+2)[0:*],
+ > w(na/num_proc_rows+2)[0:*]
+
+
+ common /urando/ amult, tran
+ double precision amult, tran
+
+
+
+ integer l2npcols
+ integer reduce_exch_proc(num_proc_cols)
+ integer reduce_send_starts(num_proc_cols)
+ integer reduce_send_lengths(num_proc_cols)
+ integer reduce_recv_lengths(num_proc_cols)
+ integer reduce_rrecv_starts(num_proc_cols)
+c---------------------------------
+c Coarray Decalarations
+c---------------------------------
+ integer reduce_recv_starts(num_proc_cols)[0:*]
+
+ integer i, j, k, it, me, nprocs, root
+
+ double precision zeta, randlc
+ external randlc
+ double precision rnorm
+c---------------------------------
+c Coarray Decalarations
+c---------------------------------
+ double precision norm_temp1(2)[0:*], norm_temp2(2)[0:*]
+
+ double precision t, tmax, mflops
+ double precision u(1), umax(1)
+ external timer_read
+ double precision timer_read
+ character class
+ logical verified
+ double precision zeta_verify_value, epsilon, err
+
+c---------------------------------------------------------------------
+c Explicit interface for conj_grad, due to coarray args
+c---------------------------------------------------------------------
+ interface
+
+ subroutine conj_grad ( colidx,
+ > rowstr,
+ > x,
+ > z,
+ > a,
+ > p,
+ > q,
+ > r,
+ > w,
+ > rnorm,
+ > l2npcols,
+ > reduce_exch_proc,
+ > reduce_send_starts,
+ > reduce_send_lengths,
+ > reduce_recv_starts,
+ > reduce_recv_lengths,
+ > reduce_rrecv_starts )
+
+ common / partit_size / naa, nzz,
+ > npcols, nprows,
+ > proc_col, proc_row,
+ > firstrow,
+ > lastrow,
+ > firstcol,
+ > lastcol,
+ > exch_proc,
+ > exch_recv_length,
+ > send_start,
+ > send_len
+
+ integer naa, nzz,
+ > npcols, nprows,
+ > proc_col, proc_row,
+ > firstrow,
+ > lastrow,
+ > firstcol,
+ > lastcol,
+ > exch_proc,
+ > exch_recv_length,
+ > send_start,
+ > send_len
+
+ double precision x(*),
+ > z(*),
+ > a(nzz)
+ integer colidx(nzz), rowstr(naa+1)
+
+ double precision p(*),
+ > q(*)[0:*],
+ > r(*)[0:*],
+ > w(*)[0:*] ! used as work temporary
+
+ integer l2npcols
+ integer reduce_exch_proc(l2npcols)
+ integer reduce_send_starts(l2npcols)
+ integer reduce_send_lengths(l2npcols)
+ integer reduce_recv_starts(l2npcols)[0:*]
+ integer reduce_recv_lengths(l2npcols)
+ integer reduce_rrecv_starts(l2npcols)
+
+ double precision rnorm
+
+ end subroutine
+
+ end interface
+
+c---------------------------------------------------------------------
+c The call to the conjugate gradient routine:
+c---------------------------------------------------------------------
+ call conj_grad ( colidx,
+ > rowstr,
+ > x,
+ > z,
+ > a,
+ > p,
+ > q,
+ > r,
+ > w,
+ > rnorm,
+ > l2npcols,
+ > reduce_exch_proc,
+ > reduce_send_starts,
+ > reduce_send_lengths,
+ > reduce_recv_starts,
+ > reduce_recv_lengths,
+ > reduce_rrecv_starts )
+
+
+ sync all
+
+ end ! end main
+
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+ subroutine conj_grad ( colidx,
+ > rowstr,
+ > x,
+ > z,
+ > a,
+ > p,
+ > q,
+ > r,
+ > w,
+ > rnorm,
+ > l2npcols,
+ > reduce_exch_proc,
+ > reduce_send_starts,
+ > reduce_send_lengths,
+ > reduce_recv_starts,
+ > reduce_recv_lengths,
+ > reduce_rrecv_starts )
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c Floaging point arrays here are named as in NPB1 spec discussion of
+c CG algorithm
+c---------------------------------------------------------------------
+
+ implicit none
+
+c include 'cafnpb.h'
+
+ common / partit_size / naa, nzz,
+ > npcols, nprows,
+ > proc_col, proc_row,
+ > firstrow,
+ > lastrow,
+ > firstcol,
+ > lastcol,
+ > exch_proc,
+ > exch_recv_length,
+ > send_start,
+ > send_len
+ integer naa, nzz,
+ > npcols, nprows,
+ > proc_col, proc_row,
+ > firstrow,
+ > lastrow,
+ > firstcol,
+ > lastcol,
+ > exch_proc,
+ > exch_recv_length,
+ > send_start,
+ > send_len
+
+
+
+ double precision x(*),
+ > z(*),
+ > a(nzz)
+ integer colidx(nzz), rowstr(naa+1)
+
+ double precision p(*),
+ > q(*)[0:*],
+ > r(*)[0:*],
+ > w(*)[0:*] ! used as work temporary
+
+ integer l2npcols
+ integer reduce_exch_proc(l2npcols)
+ integer reduce_send_starts(l2npcols)
+ integer reduce_send_lengths(l2npcols)
+ integer reduce_recv_starts(l2npcols)[0:*]
+ integer reduce_recv_lengths(l2npcols)
+ integer reduce_rrecv_starts(l2npcols)
+
+ integer recv_start_idx, recv_end_idx, send_start_idx,
+ > send_end_idx, recv_length
+
+ integer i, j, k, ierr
+ integer cgit, cgitmax
+
+ double precision, save :: d[0:*], rho[0:*]
+ double precision sum, rho0, alpha, beta, rnorm
+
+ external timer_read
+ double precision timer_read
+
+ data cgitmax / 25 /
+
+
+ return
+ end ! end of routine conj_grad
+
diff --git a/gcc/testsuite/gfortran.dg/coarray_37.f90 b/gcc/testsuite/gfortran.dg/coarray_37.f90
new file mode 100644
index 0000000..6f56c32
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_37.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+ program cg
+ implicit none
+ integer reduce_recv_starts(2)[1,0:*]
+ interface
+ subroutine conj_grad (reduce_recv_starts) ! { dg-warning "Interface mismatch in global procedure 'conj_grad' at \\(1\\): Corank mismatch in argument 'reduce_recv_starts' \\(2/1\\)" }
+ integer reduce_recv_starts(2)[2, 2:*]
+ end subroutine
+ end interface
+ call conj_grad (reduce_recv_starts) ! Corank mismatch is okay
+ end
+
+ subroutine conj_grad (reduce_recv_starts)
+ implicit none
+ integer reduce_recv_starts(2)[2:*]
+ end