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! 6module 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 24contains 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 61end module psb_penv_mod 62 63 64module 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 79end module psb_indx_map_mod 80 81 82 83module 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 98contains 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 153end module psb_gen_block_map_mod 154 155 156module 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 177end module psb_descriptor_type 178 179module 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 198end module psb_cd_if_tools_mod 199 200module 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 220end module psb_cd_tools_mod 221module psb_base_tools_mod 222 use psb_cd_tools_mod 223end module psb_base_tools_mod 224 225subroutine 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 261end subroutine psb_cdall 262