Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/class_37.f03 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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