gcc/testsuite/gfortran.dg/class_37.f03

   1 ! { dg-do compile }
   2 ! { dg-require-visibility "" }
   3 ! Test fix for PR47082, in which an ICE in the ALLOCATE at line 248.
   4 !
   5 ! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
   6 !
   7 module psb_penv_mod
   8
   9   interface psb_init
  10     module procedure  psb_init
  11   end interface
  12
  13   interface psb_exit
  14     module procedure  psb_exit
  15   end interface
  16
  17   interface psb_info
  18     module procedure psb_info
  19   end interface
  20
  21   integer, private, save :: nctxt=0
  22
  23
  24
  25 contains
  26
  27
  28   subroutine psb_init(ictxt,np,basectxt,ids)
  29     implicit none
  30     integer, intent(out) :: ictxt
  31     integer, intent(in), optional :: np, basectxt, ids(:)
  32
  33
  34     ictxt = nctxt
  35     nctxt = nctxt + 1
  36
  37   end subroutine psb_init
  38
  39   subroutine psb_exit(ictxt,close)
  40     implicit none
  41     integer, intent(inout) :: ictxt
  42     logical, intent(in), optional :: close
  43
  44     nctxt = max(0, nctxt - 1)
  45
  46   end subroutine psb_exit
  47
  48
  49   subroutine psb_info(ictxt,iam,np)
  50
  51     implicit none
  52
  53     integer, intent(in)  :: ictxt
  54     integer, intent(out) :: iam, np
  55
  56     iam = 0
  57     np  = 1
  58
  59   end subroutine psb_info
  60
  61
  62 end module psb_penv_mod
  63
  64
  65 module psb_indx_map_mod
  66
  67   type      :: psb_indx_map
  68
  69     integer :: state          = -1
  70     integer :: ictxt          = -1
  71     integer :: mpic           = -1
  72     integer :: global_rows    = -1
  73     integer :: global_cols    = -1
  74     integer :: local_rows     = -1
  75     integer :: local_cols     = -1
  76
  77
  78   end type psb_indx_map
  79
  80 end module psb_indx_map_mod
  81
  82
  83
  84 module psb_gen_block_map_mod
  85   use psb_indx_map_mod
  86
  87   type, extends(psb_indx_map) :: psb_gen_block_map
  88     integer :: min_glob_row   = -1
  89     integer :: max_glob_row   = -1
  90     integer, allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:)
  91   contains
  92
  93     procedure, pass(idxmap)  :: gen_block_map_init => block_init
  94
  95   end type psb_gen_block_map
  96
  97   private ::  block_init
  98
  99 contains
 100
 101   subroutine block_init(idxmap,ictxt,nl,info)
 102     use psb_penv_mod
 103     implicit none
 104     class(psb_gen_block_map), intent(inout) :: idxmap
 105     integer, intent(in)  :: ictxt, nl
 106     integer, intent(out) :: info
 107     !  To be implemented
 108     integer :: iam, np, i, j, ntot
 109     integer, allocatable :: vnl(:)
 110
 111     info = 0
 112     call psb_info(ictxt,iam,np)
 113     if (np < 0) then
 114       info = -1
 115       return
 116     end if
 117
 118     allocate(vnl(0:np),stat=info)
 119     if (info /= 0)  then
 120       info = -2
 121       return
 122     end if
 123
 124     vnl(:)   = 0
 125     vnl(iam) = nl
 126     ntot = sum(vnl)
 127     vnl(1:np) = vnl(0:np-1)
 128     vnl(0) = 0
 129     do i=1,np
 130       vnl(i) = vnl(i) + vnl(i-1)
 131     end do
 132     if (ntot /= vnl(np)) then
 133 ! !$      write(0,*) ' Mismatch in block_init ',ntot,vnl(np)
 134     end if
 135
 136     idxmap%global_rows  = ntot
 137     idxmap%global_cols  = ntot
 138     idxmap%local_rows   = nl
 139     idxmap%local_cols   = nl
 140     idxmap%ictxt        = ictxt
 141     idxmap%state        = 1
 142
 143     idxmap%min_glob_row = vnl(iam)+1
 144     idxmap%max_glob_row = vnl(iam+1)
 145     call move_alloc(vnl,idxmap%vnl)
 146     allocate(idxmap%loc_to_glob(nl),stat=info)
 147     if (info /= 0)  then
 148       info = -2
 149       return
 150     end if
 151
 152   end subroutine block_init
 153
 154 end module psb_gen_block_map_mod
 155
 156
 157 module psb_descriptor_type
 158   use psb_indx_map_mod
 159
 160   implicit none
 161
 162
 163   type psb_desc_type
 164     integer, allocatable  :: matrix_data(:)
 165     integer, allocatable  :: halo_index(:)
 166     integer, allocatable  :: ext_index(:)
 167     integer, allocatable  :: ovrlap_index(:)
 168     integer, allocatable  :: ovrlap_elem(:,:)
 169     integer, allocatable  :: ovr_mst_idx(:)
 170     integer, allocatable  :: bnd_elem(:)
 171     class(psb_indx_map), allocatable :: indxmap
 172     integer, allocatable  :: lprm(:)
 173     type(psb_desc_type), pointer     :: base_desc => null()
 174     integer, allocatable  :: idx_space(:)
 175   end type psb_desc_type
 176
 177
 178 end module psb_descriptor_type
 179
 180 module psb_cd_if_tools_mod
 181
 182   use psb_descriptor_type
 183   use psb_gen_block_map_mod
 184
 185   interface psb_cdcpy
 186     subroutine psb_cdcpy(desc_in, desc_out, info)
 187       use psb_descriptor_type
 188
 189       implicit none
 190       !....parameters...
 191
 192       type(psb_desc_type), intent(in)  :: desc_in
 193       type(psb_desc_type), intent(out) :: desc_out
 194       integer, intent(out)             :: info
 195     end subroutine psb_cdcpy
 196   end interface
 197
 198
 199 end module psb_cd_if_tools_mod
 200
 201 module psb_cd_tools_mod
 202
 203   use psb_cd_if_tools_mod
 204
 205   interface psb_cdall
 206
 207     subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck)
 208       use psb_descriptor_type
 209       implicit None
 210       Integer, intent(in)               :: mg,ng,ictxt, vg(:), vl(:),nl
 211       integer, intent(in)               :: flag
 212       logical, intent(in)               :: repl, globalcheck
 213       integer, intent(out)              :: info
 214       type(psb_desc_type), intent(out)  :: desc
 215
 216       optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck
 217     end subroutine psb_cdall
 218
 219   end interface
 220
 221 end module psb_cd_tools_mod
 222 module psb_base_tools_mod
 223   use psb_cd_tools_mod
 224 end module psb_base_tools_mod
 225
 226 subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck)
 227   use psb_descriptor_type
 228   use psb_gen_block_map_mod
 229   use psb_base_tools_mod, psb_protect_name => psb_cdall
 230   implicit None
 231   Integer, intent(in)               :: mg,ng,ictxt, vg(:), vl(:),nl
 232   integer, intent(in)               :: flag
 233   logical, intent(in)               :: repl, globalcheck
 234   integer, intent(out)              :: info
 235   type(psb_desc_type), intent(out)  :: desc
 236
 237   optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck
 238   integer :: err_act, n_, flag_, i, me, np, nlp, nnv, lr
 239   integer, allocatable :: itmpsz(:)
 240
 241
 242
 243   info = 0
 244   desc%base_desc => null()
 245   if (allocated(desc%indxmap)) then
 246     write(0,*) 'Allocated on an intent(OUT) var?'
 247   end if
 248
 249   allocate(psb_gen_block_map :: desc%indxmap, stat=info)
 250   if (info == 0) then
 251     select type(aa => desc%indxmap)
 252     type is (psb_gen_block_map)
 253       call aa%gen_block_map_init(ictxt,nl,info)
 254     class default
 255         ! This cannot happen
 256       info = -1
 257     end select
 258   end if
 259
 260   return
 261
 262 end subroutine psb_cdall