Internal compiler error -fcoarray=single

[VladimÃr Fuka <vladimir dot fuka at gmail dot com>]

Hello,

  I get an internal compiler error for the coarray program below. It
is probably not correct. Tried with gfortran-4.8 -g jac.f90
-fcoarray=single , recent gfortran build. I hope, it can be useful for
you.

   Vladimir Fuka

lada@spiranthes:~/f/coarray/jac> gfortran-4.8 -v
Using built-in specs.
COLLECT_GCC=gfortran-4.8
COLLECT_LTO_WRAPPER=/usr/local/gcc-4.8/libexec/gcc/x86_64-unknown-linux-gnu/4.8.0/lto-wrapper
Target: x86_64-unknown-linux-gnu
Configured with: ../gcc-4.8-20120624/configure
--enable-languages=fortran --prefix=/usr/local/gcc-4.8
Thread model: posix
gcc version 4.8.0 20120624 (experimental) (GCC)



Program:

program Jac
 implicit none

 integer,parameter:: KND=KIND(1.0)

 type Domain
  real(KND),dimension(:,:,:),allocatable:: A,B
  integer :: n=64,niter=20000,blockit=1000
  integer :: starti,endi
  integer :: startj,endj
  integer :: startk,endk
  integer,dimension(:),allocatable :: startsi,startsj,startsk
  integer,dimension(:),allocatable :: endsi,endsj,endsk
 end type

 type(Domain),allocatable :: D[:,:,:]
 real(KND),codimension[*] :: sumA,sumB,diffAB
 real(KND) avgA,avgB
 integer i,j,k,ncom
 integer nims,nxims,nyims,nzims
 integer im,iim,jim,kim
 real p,S
 character(20):: ch

 nims = num_images()
 nxims = nint(nims**(1./3.))
 nyims = nint(nims**(1./3.))
 nzims = nims / (nxims*nyims)

 im = this_image()
 if (im==1) write(*,*) "n: [",nxims,nyims,nzims,"]"

 kim = (im-1) / (nxims*nyims) + 1
 jim = ((im-1) - (kim-1)*(nxims*nyims)) / nxims + 1
 iim = (im-1) - (kim-1)*(nxims*nyims) - (jim-1)*(nxims) + 1

 write (*,*) im,"[",iim,jim,kim,"]"

 allocate(D[nxims,nyims,*])

 ncom=command_argument_count()
 if (command_argument_count() >=2) then
  call get_command_argument(1,value=ch)
  read (ch,*) D%n
  call get_command_argument(2,value=ch)
  read (ch,*) D%niter
  call get_command_argument(3,value=ch)
  read (ch,*) D%blockit
 end if

 allocate(D%startsi(nxims))
 allocate(D%startsj(nyims))
 allocate(D%startsk(nzims))
 allocate(D%endsi(nxims))
 allocate(D%endsj(nyims))
 allocate(D%endsk(nzims))

 D%startsi(1) = 1
 do i=2,nxims
   D%startsi(i) = D%startsi(i-1) + D%n/nxims
 end do
 D%endsi(nxims) = D%n
 D%endsi(1:nxims-1) = D%startsi(2:nxims) - 1

 D%startsj(1) = 1
 do j=2,nyims
   D%startsj(j) = D%startsj(j-1) + D%n/nyims
 end do
 D%endsj(nyims) = D%n
 D%endsj(1:nyims-1) = D%startsj(2:nyims) - 1

 D%startsk(1) = 1
 do k=2,nzims
   D%startsk(k) = D%startsk(k-1) + D%n/nzims
 end do
 D%endsk(nzims) = D%n
 D%endsk(1:nzims-1) = D%startsk(2:nzims) - 1

 D%starti = D%startsi(iim)
 D%endi = D%endsi(iim)
 D%startj = D%startsj(jim)
 D%endj = D%endsj(jim)
 D%startk = D%startsk(kim)
 D%endk = D%endsk(kim)

 write(*,*) D%startsi,D%endsi
 write(*,*) D%startsj,D%endsj
 write(*,*) D%startsk,D%endsk

 !$hmpp JacKernel allocate, args[A,B].size={0:D%n+1,0:D%n+1,0:D%n+1}
 allocate(D%A(D%starti-1:D%endi+1,D%startj-1:D%endj+1,D%startk-1:D%endk+1),&
  D%B(D%starti-1:D%endi+1,D%startj-1:D%endj+1,D%startk-1:D%endk+1))
 D%A=0
 D%B=0
 if (iim==nxims) then
   D%A(D%endi+1,:,:)=1
   D%B(D%endi+1,:,:)=1
 endif
!
!  do k=1,D%n
!   do j=1,D%n
!    do i=1,D%n
!      !call RANDOM_NUMBER(p)
!      D%A(i,j,k)=sin(REAL(i+j+k))
!    enddo
!   enddo
!  enddo
!  D%B=D%A
  sumA = sum(D%A(D%starti:D%endi,D%startj:D%endj,D%startk:D%endk))
  sumB = sum(D%B(D%starti:D%endi,D%startj:D%endj,D%startk:D%endk))

  if (im==1) then
    sync images(*)
  else
    sync images(1)
  endif

  if (im==1) then
    do i=1,nims
      avgA = avgA + sumA[i]
      avgB = avgB + sumB[i]
    end do
    avgA = avgA / D%n**3
    avgB = avgB / D%n**3
    write(*,*) avgA,avgB
  end if

  sync all

  k=0
  do
    call Boundaries(D)

    sync all
    !$hmpp JacKernel callsite
    call JacKernel(D%starti,D%endi,D%startj,D%endj,D%startk,D%endk,D%A,D%B,D%niter)

    sync all

    diffAB = DifferenceAB(D)
    if (im==1) write(*,*) sum(D%A),sum(D%B),diffAB

    k=k+D%blockit
    if (k>=D%niter) exit
  enddo

  deallocate(D%A,D%B,D%startsi,D%endsi,D%startsj,D%endsj,D%startsk,D%endsk)
  deallocate(D)

 contains

  !$hmpp JacKernel codelet, target=CUDA
  subroutine JacKernel(starti,endi,startj,endj,startk,endk,A,B,nit)
   implicit none
   integer,intent(in) :: starti,endi,startj,endj,startk,endk
   real(KND),dimension(starti-1:endi+1,startj-1:endj-1,startk-1:endk+1),intent(inout)::A,B
   integer,intent(in):: nit
!    real(KND),dimension(0:D%n+1,0:D%n+1,0:D%n+1)::B
   integer i,j,k,l
   real(KND),parameter :: p = 1._KND/6._KND

 do l=1,nit
!   if (mod(l,2)==1) then
   !$hmppcg grid blocksize 512x1
   !$hmppcg permute k,i,j
   do k=startk,endk
    do j=startj,endj
     do i=starti,endi
      B(i,j,k)=(A(i+1,j,k)+A(i-1,j,k)+A(i,j+1,k)+A(i,j-1,k)+A(i,j,k+1)+A(i,j,k-1))
      B(i,j,k)=B(i,j,k)*p
     enddo
    enddo
   enddo
!  else
!    !$hmppcg grid blocksize 512x1
!    !$hmppcg permute k,i,j
!    do k=startk,endk
!     do j=startj,endj
!      do i=starti,endi
!       A(i,j,k)=(B(i+1,j,k)+B(i-1,j,k)+B(i,j+1,k)+B(i,j-1,k)+B(i,j,k+1)+B(i,j,k-1))
!       A(i,j,k)=A(i,j,k)*p
!      enddo
!     enddo
!    enddo
!   endif

   do k=startk,endk
    do j=startj,endj
     do i=starti,endi
      A(i,j,k)=B(i,j,k)
     enddo
    enddo
   enddo
 enddo
  endsubroutine JacKernel

  subroutine Boundaries(D)
    type(Domain),allocatable :: D[:,:,:]

    sync all
      if (iim>1) then
       D%A(D%starti-1,D%startj:D%endj,D%startk:D%endk) =&
           D[iim-1,jim,kim]%A(D%endsi(iim-1),D%startj:D%endj,D%startk:D%endk)
      end if
      if (iim<nxims) then
       D%A(D%endi+1,D%startj:D%endj,D%startk:D%endk) =&
           D[iim+1,jim,kim]%A(D%startsi(iim+1),D%startj:D%endj,D%startk:D%endk)
      end if

      if (jim>1) then
       D%A(D%starti:D%endi,D%startj-1,D%startk:D%endk) =&
           D[iim,jim-1,kim]%A(D%starti:D%endi,D%endsj(jim-1),D%startk:D%endk)
      end if
      if (jim<nyims) then
       D%A(D%starti:D%endi,D%endj+1,D%startk:D%endk) =&
           D[iim,jim+1,kim]%A(D%starti:D%endi,D%startsj(jim+1),D%startk:D%endk)
      end if

      if (kim>1) then
       D%A(D%starti:D%endi,D%startj:D%endj,D%startk-1) =&
           D[iim,jim,kim-1]%A(D%starti:D%endi,D%startj:D%endj,D%endsk(kim-1))
      end if
      if (kim<nzims) then
       D%A(D%starti:D%endi,D%startj:D%endj,D%startk+1) =&
           D[iim,jim,kim+1]%A(D%starti:D%endi,D%startj:D%endj,D%startsk(kim+1))
      end if

    sync all
  end subroutine Boundaries


   function DifferenceAB(D) result(res)
    real(KND) :: res
    type(Domain),allocatable,intent(in) :: D[:,:,:]
    real(KND),allocatable :: diffloc[:],diffAB[:]
    integer i

     allocate(diffloc[*],diffAB[*])

     diffloc = maxval(D%A(D%starti:D%endi,D%startj:D%endj,D%startk:D%endk)-&
                  D%B(D%starti:D%endi,D%startj:D%endj,D%startk:D%endk))
write(*,*) "diffloc",diffloc
     if (im==1) then
        sync images(*)
     else
        sync images(1)
     endif

     if (im==1) then
        diffAB=0
        do i=1,nims
          diffAB = max(diffAB, diffloc[i])
        end do
     end if

     if (im==1) then
        sync images(*)
     else
        sync images(1)
     endif

     if (im>1) diffAB=diffAB[1]

write(*,*) "diffAB",diffAB

     if (im==1) then
        sync images(*)
     else
        sync images(1)
     endif

     res = diffAB

  end function DifferenceAB

end program Jac