re PR fortran/64771 (ICE(segfault) when passing coarrays around; ICE in gfc_zero_size_array in arith.c:1637)
2015-01-26 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.
From-SVN: r220136
This commit is contained in:
Tobias Burnus
Tobias Burnus
parent
c123c5ba64
commit
b25affbdc1
@ -1,3 +1,8 @@
|
||||
2015-01-26 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/64771
|
||||
* interface.c (check_dummy_characteristics): Fix coarray handling.
|
||||
|
||||
2015-01-26 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
* io.c (gfc_match_inquire): Replace "-1" by a defined constant.
|
||||
|
||||
@ -63,6 +63,8 @@ along with GCC; see the file COPYING3. If not see
|
||||
formal argument list points to symbols within the same namespace as
|
||||
the program unit name. */
|
||||
|
||||
#include <algorithm> /* For std::max. */
|
||||
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#include "coretypes.h"
|
||||
@ -1205,8 +1207,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 +1229,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:
|
||||
|
||||
@ -1,3 +1,9 @@
|
||||
2015-01-26 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/64771
|
||||
* gfortran.dg/coarray_36.f: New.
|
||||
* gfortran.dg/coarray_37.f90: New.
|
||||
|
||||
2015-01-26 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/64230
|
||||
|
||||
347
gcc/testsuite/gfortran.dg/coarray_36.f
Normal file
347
gcc/testsuite/gfortran.dg/coarray_36.f
Normal file
@ -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
|
||||
|
||||
18
gcc/testsuite/gfortran.dg/coarray_37.f90
Normal file
18
gcc/testsuite/gfortran.dg/coarray_37.f90
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user