diff mbox

[Fortran] PR64771 - Fix coarray ICE

Message ID 54C3D2A0.5090905@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Jan. 24, 2015, 5:13 p.m. UTC
Build and regtested on x86-64-gnu-linux.
OK for the trunk and 4.9? (It's a regression.)

Tobias

Comments

Steve Kargl Jan. 24, 2015, 8:11 p.m. UTC | #1
On Sat, Jan 24, 2015 at 06:13:04PM +0100, Tobias Burnus wrote:
>        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++)

Doesn't this require '#include <algorithms>'?
I suspect that you are depending on namespace pollution
via some other header (coretypes.h?).
diff mbox

Patch

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