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!
7module 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
25contains
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
62end module psb_penv_mod
63
64
65module 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
80end module psb_indx_map_mod
81
82
83
84module 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
99contains
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
154end module psb_gen_block_map_mod
155
156
157module 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
178end module psb_descriptor_type
179
180module 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
199end module psb_cd_if_tools_mod
200
201module 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
221end module psb_cd_tools_mod
222module psb_base_tools_mod
223  use psb_cd_tools_mod
224end module psb_base_tools_mod
225
226subroutine 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
262end subroutine psb_cdall
263