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