gcc/testsuite/gfortran.dg/pr96737.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fcoarray=single -g" }
   3 !
   4 ! Test the fix for PR96737 in which the 'TYPE_CANONICAL' was not campatible
   5 ! in the submodule.
   6 !
   7 ! Contributed by Andre Vehreschild  <vehre@gcc.gnu.org>
   8 !
   9 module surface_packages
  10   implicit none
  11
  12   type flux_planes
  13     integer, allocatable :: normals(:,:)
  14   end type
  15
  16   type package
  17     integer id
  18     type(flux_planes), allocatable :: surface_fluxes(:)
  19     integer, allocatable :: positions(:,:,:,:)
  20   end type
  21
  22   type surfaces
  23     type(package), allocatable :: halo_outbox(:,:,:)
  24   contains
  25     procedure, nopass :: set_halo_outbox
  26     procedure, nopass :: get_surface_normal_spacing
  27   end type
  28
  29   type problem_discretization
  30     type(surfaces) block_surfaces
  31   end type
  32
  33   interface
  34     module subroutine set_halo_outbox(my_halo_outbox)
  35       implicit none
  36       type(package), intent(in) :: my_halo_outbox(:,:,:)
  37     end subroutine
  38
  39     module subroutine get_surface_normal_spacing
  40     end subroutine
  41   end interface
  42
  43 end module
  44
  45 submodule(surface_packages) implementation
  46   implicit none
  47   type(surfaces), save :: singleton[*]
  48 contains
  49
  50   module procedure get_surface_normal_spacing
  51     integer i, b, d, f
  52
  53     do i=1,num_images()
  54       associate( positions => reshape(i*[5,4,3,2], [2,1,1,2]), normals => reshape(i*[6,6,6], [3,1]) )
  55         do b=1,size(singleton[i]%halo_outbox,1)
  56           do d=1,size(singleton[i]%halo_outbox,2)
  57             do f=1,size(singleton[i]%halo_outbox,3)
  58               if ( .not. all([singleton[i]%halo_outbox(b,d,f)%positions == positions]) ) error stop "positions"
  59               if ( .not. all([singleton[i]%halo_outbox(b,d,f)%surface_fluxes(1)%normals == normals] ) )  error stop "normals"
  60             end do
  61           end do
  62         end do
  63       end associate
  64     end do
  65   end procedure
  66
  67   module procedure set_halo_outbox
  68     singleton%halo_outbox = my_halo_outbox
  69     sync all
  70   end procedure
  71
  72 end submodule
  73
  74 program main
  75   use surface_packages, only : problem_discretization, package
  76   implicit none
  77   type(problem_discretization) global_grid
  78   type(package), allocatable :: bare(:,:,:)
  79   integer i, j, k
  80
  81   associate( me=>this_image() )
  82
  83     allocate( bare(me,3,2) )
  84
  85     do i=1, size(bare,1)
  86       bare(i,:,:)%id = i
  87       do j=1, size(bare,2)
  88         do k=1, size(bare,3)
  89           bare(i,j,k)%positions =  reshape(me*[5,4,3,2], [2,1,1,2])
  90           allocate( bare(i,j,k)%surface_fluxes(1) )
  91           bare(i,j,k)%surface_fluxes(1)%normals = reshape(me*[6,6,6], [3,1])
  92         end do
  93       end do
  94     end do
  95
  96     call global_grid%block_surfaces%set_halo_outbox(bare)
  97     call global_grid%block_surfaces%get_surface_normal_spacing
  98
  99   end associate
 100
 101   sync all
 102   if (this_image()==1) print *,"Test passed"
 103 end program main