gcc/testsuite/gfortran.dg/class_37.f03

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