1 | MODULE domain_mod |
---|
2 | USE domain_param |
---|
3 | |
---|
4 | TYPE t_domain |
---|
5 | INTEGER :: face |
---|
6 | INTEGER :: iim |
---|
7 | INTEGER :: jjm |
---|
8 | INTEGER :: ii_begin |
---|
9 | INTEGER :: jj_begin |
---|
10 | INTEGER :: ii_end |
---|
11 | INTEGER :: jj_end |
---|
12 | INTEGER :: ii_nb |
---|
13 | INTEGER :: jj_nb |
---|
14 | INTEGER :: ii_begin_glo |
---|
15 | INTEGER :: jj_begin_glo |
---|
16 | INTEGER :: ii_end_glo |
---|
17 | INTEGER :: jj_end_glo |
---|
18 | INTEGER,POINTER :: assign_domain(:,:) |
---|
19 | INTEGER,POINTER :: assign_cell_glo(:,:) |
---|
20 | INTEGER,POINTER :: assign_i(:,:) |
---|
21 | INTEGER,POINTER :: assign_j(:,:) |
---|
22 | INTEGER,POINTER :: edge_assign_domain(:,:,:) |
---|
23 | INTEGER,POINTER :: edge_assign_i(:,:,:) |
---|
24 | INTEGER,POINTER :: edge_assign_j(:,:,:) |
---|
25 | INTEGER,POINTER :: edge_assign_pos(:,:,:) |
---|
26 | INTEGER,POINTER :: edge_assign_sign(:,:,:) |
---|
27 | INTEGER,POINTER :: vertex_assign_domain(:,:,:) |
---|
28 | INTEGER,POINTER :: vertex_assign_i(:,:,:) |
---|
29 | INTEGER,POINTER :: vertex_assign_j(:,:,:) |
---|
30 | INTEGER,POINTER :: vertex_assign_pos(:,:,:) |
---|
31 | REAL,POINTER :: xyz(:,:,:) |
---|
32 | REAL,POINTER :: neighbour(:,:,:,:) |
---|
33 | INTEGER,POINTER :: delta(:,:) |
---|
34 | REAL,POINTER :: vertex(:,:,:,:) |
---|
35 | LOGICAL,POINTER :: own(:,:) |
---|
36 | INTEGER,POINTER :: ne(:,:,:) |
---|
37 | |
---|
38 | INTEGER :: t_right |
---|
39 | INTEGER :: t_rup |
---|
40 | INTEGER :: t_lup |
---|
41 | INTEGER :: t_left |
---|
42 | INTEGER :: t_ldown |
---|
43 | INTEGER :: t_rdown |
---|
44 | |
---|
45 | INTEGER :: u_right |
---|
46 | INTEGER :: u_rup |
---|
47 | INTEGER :: u_lup |
---|
48 | INTEGER :: u_left |
---|
49 | INTEGER :: u_ldown |
---|
50 | INTEGER :: u_rdown |
---|
51 | |
---|
52 | INTEGER :: z_rup |
---|
53 | INTEGER :: z_up |
---|
54 | INTEGER :: z_lup |
---|
55 | INTEGER :: z_ldown |
---|
56 | INTEGER :: z_down |
---|
57 | INTEGER :: z_rdown |
---|
58 | |
---|
59 | INTEGER :: t_pos(6) |
---|
60 | INTEGER :: u_pos(6) |
---|
61 | INTEGER :: z_pos(6) |
---|
62 | |
---|
63 | END TYPE t_domain |
---|
64 | |
---|
65 | INTEGER,SAVE :: ndomain |
---|
66 | INTEGER,SAVE :: ndomain_glo |
---|
67 | |
---|
68 | TYPE(t_domain),SAVE,ALLOCATABLE,TARGET :: domain(:) |
---|
69 | TYPE(t_domain),SAVE,ALLOCATABLE,TARGET :: domain_glo(:) |
---|
70 | |
---|
71 | INTEGER,ALLOCATABLE,SAVE :: domglo_rank(:) ! size : ndomain_glo : mpi rank assigned to a domain |
---|
72 | INTEGER,ALLOCATABLE,SAVE :: domglo_loc_ind(:) ! size : ndomain_glo : corresponding local indice for a global domain indice |
---|
73 | INTEGER,ALLOCATABLE,SAVE :: domloc_glo_ind(:) ! size : ndomain : corresponding global indice for a local domain indice |
---|
74 | |
---|
75 | LOGICAL, ALLOCATABLE, SAVE :: assigned_domain(:) ! size : ndomain : is an omp task is assigned to this domain |
---|
76 | !$OMP THREADPRIVATE(assigned_domain) |
---|
77 | |
---|
78 | CONTAINS |
---|
79 | |
---|
80 | SUBROUTINE create_domain |
---|
81 | USE grid_param |
---|
82 | USE mpipara |
---|
83 | USE ioipsl |
---|
84 | IMPLICIT NONE |
---|
85 | INTEGER :: ind,nf,ni,nj |
---|
86 | INTEGER :: quotient, rest |
---|
87 | INTEGER :: halo_i,halo_j |
---|
88 | |
---|
89 | TYPE(t_domain),POINTER :: d |
---|
90 | |
---|
91 | ndomain_glo=nsplit_i*nsplit_j*nb_face |
---|
92 | ALLOCATE(domain_glo(ndomain_glo)) |
---|
93 | ALLOCATE(domglo_rank(ndomain_glo)) |
---|
94 | ALLOCATE(domglo_loc_ind(ndomain_glo)) |
---|
95 | |
---|
96 | halo_i=0 |
---|
97 | CALL getin("halo_i",halo_i) |
---|
98 | halo_j=1 |
---|
99 | CALL getin("halo_j",halo_j) |
---|
100 | |
---|
101 | ind=0 |
---|
102 | DO nf=1,nb_face |
---|
103 | DO nj=1,nsplit_j |
---|
104 | DO ni=1,nsplit_i |
---|
105 | ind=ind+1 |
---|
106 | d=>domain_glo(ind) |
---|
107 | quotient=(iim_glo/nsplit_i) |
---|
108 | rest=MOD(iim_glo,nsplit_i) |
---|
109 | IF (ni-1 < rest) THEN |
---|
110 | d%ii_nb=quotient+1 |
---|
111 | d%ii_begin_glo=(quotient+1)*(ni-1)+1 |
---|
112 | ELSE |
---|
113 | d%ii_nb=quotient |
---|
114 | d%ii_begin_glo=(quotient+1)*rest+(ni-1-rest) * quotient+1 |
---|
115 | ENDIF |
---|
116 | d%ii_end_glo=d%ii_begin_glo+d%ii_nb-1 |
---|
117 | |
---|
118 | IF (ni/=1) THEN |
---|
119 | d%ii_nb=d%ii_nb+1 |
---|
120 | d%ii_begin_glo=d%ii_begin_glo-1 |
---|
121 | ENDIF |
---|
122 | |
---|
123 | |
---|
124 | quotient=(jjm_glo/nsplit_j) |
---|
125 | rest=MOD(jjm_glo,nsplit_j) |
---|
126 | IF (nj-1 < rest) THEN |
---|
127 | d%jj_nb=quotient+1 |
---|
128 | d%jj_begin_glo=(quotient+1)*(nj-1)+1 |
---|
129 | ELSE |
---|
130 | d%jj_nb=quotient |
---|
131 | d%jj_begin_glo=(quotient+1)*rest+(nj-1-rest) * quotient+1 |
---|
132 | ENDIF |
---|
133 | d%jj_end_glo=d%jj_begin_glo+d%jj_nb-1 |
---|
134 | |
---|
135 | IF (nj/=1) THEN |
---|
136 | d%jj_nb=d%jj_nb+1 |
---|
137 | d%jj_begin_glo=d%jj_begin_glo-1 |
---|
138 | ENDIF |
---|
139 | |
---|
140 | |
---|
141 | d%iim=d%ii_nb+2*halo + halo_i*2 |
---|
142 | d%jjm=d%jj_nb+2*halo + halo_j*2 |
---|
143 | d%ii_begin=halo+1 + halo_i |
---|
144 | d%jj_begin=halo+1 + halo_j |
---|
145 | d%ii_end=d%ii_begin+d%ii_nb-1 |
---|
146 | d%jj_end=d%jj_begin+d%jj_nb-1 |
---|
147 | d%face=nf |
---|
148 | ALLOCATE(d%assign_domain(d%iim,d%jjm)) |
---|
149 | ALLOCATE(d%assign_cell_glo(d%iim,d%jjm)) |
---|
150 | ALLOCATE(d%assign_i(d%iim,d%jjm)) |
---|
151 | ALLOCATE(d%assign_j(d%iim,d%jjm)) |
---|
152 | ALLOCATE(d%edge_assign_domain(0:5,d%iim,d%jjm)) |
---|
153 | ALLOCATE(d%edge_assign_i(0:5,d%iim,d%jjm)) |
---|
154 | ALLOCATE(d%edge_assign_j(0:5,d%iim,d%jjm)) |
---|
155 | ALLOCATE(d%edge_assign_pos(0:5,d%iim,d%jjm)) |
---|
156 | ALLOCATE(d%edge_assign_sign(0:5,d%iim,d%jjm)) |
---|
157 | ALLOCATE(d%vertex_assign_domain(0:5,d%iim,d%jjm)) |
---|
158 | ALLOCATE(d%vertex_assign_i(0:5,d%iim,d%jjm)) |
---|
159 | ALLOCATE(d%vertex_assign_j(0:5,d%iim,d%jjm)) |
---|
160 | ALLOCATE(d%vertex_assign_pos(0:5,d%iim,d%jjm)) |
---|
161 | ALLOCATE(d%delta(d%iim,d%jjm)) |
---|
162 | ALLOCATE(d%xyz(3,d%iim,d%jjm)) |
---|
163 | ALLOCATE(d%vertex(3,0:5,d%iim,d%jjm)) |
---|
164 | ALLOCATE(d%neighbour(3,0:5,d%iim,d%jjm)) |
---|
165 | ALLOCATE(d%own(d%iim,d%jjm)) |
---|
166 | ALLOCATE(d%ne(0:5,d%iim,d%jjm)) |
---|
167 | |
---|
168 | IF (is_mpi_root) PRINT *,"Domain ",ind," : size ",d%ii_nb,"x",d%jj_nb |
---|
169 | |
---|
170 | END DO |
---|
171 | END DO |
---|
172 | END DO |
---|
173 | |
---|
174 | END SUBROUTINE create_domain |
---|
175 | |
---|
176 | SUBROUTINE copy_domain(d1,d2) |
---|
177 | IMPLICIT NONE |
---|
178 | TYPE(t_domain),TARGET,INTENT(IN) :: d1 |
---|
179 | TYPE(t_domain), INTENT(OUT) :: d2 |
---|
180 | |
---|
181 | d2%iim = d1%iim |
---|
182 | d2%jjm = d1%jjm |
---|
183 | d2%ii_begin = d1%ii_begin |
---|
184 | d2%jj_begin = d1%jj_begin |
---|
185 | d2%ii_end = d1%ii_end |
---|
186 | d2%jj_end = d1%jj_end |
---|
187 | d2%ii_nb = d1%ii_nb |
---|
188 | d2%jj_nb = d1%jj_nb |
---|
189 | d2%ii_begin_glo = d1%ii_begin_glo |
---|
190 | d2%jj_begin_glo = d1%jj_begin_glo |
---|
191 | d2%ii_end_glo = d1%ii_end_glo |
---|
192 | d2%jj_end_glo = d1%jj_end_glo |
---|
193 | d2%assign_domain => d1%assign_domain |
---|
194 | d2%assign_cell_glo => d1%assign_cell_glo |
---|
195 | d2%assign_i => d1%assign_i |
---|
196 | d2%assign_j => d1%assign_j |
---|
197 | d2%edge_assign_domain => d1%edge_assign_domain |
---|
198 | d2%edge_assign_i => d1%edge_assign_i |
---|
199 | d2%edge_assign_j => d1%edge_assign_j |
---|
200 | d2%edge_assign_pos => d1%edge_assign_pos |
---|
201 | d2%edge_assign_sign => d1%edge_assign_sign |
---|
202 | d2%vertex_assign_domain => d1%vertex_assign_domain |
---|
203 | d2%vertex_assign_i => d1%vertex_assign_i |
---|
204 | d2%vertex_assign_j => d1%vertex_assign_j |
---|
205 | d2%vertex_assign_pos => d1%vertex_assign_pos |
---|
206 | d2%xyz => d1%xyz |
---|
207 | d2%neighbour => d1%neighbour |
---|
208 | d2%delta => d1%delta |
---|
209 | d2%vertex => d1%vertex |
---|
210 | d2%own => d1%own |
---|
211 | d2%ne => d1%ne |
---|
212 | |
---|
213 | d2%t_right = d1%t_right |
---|
214 | d2%t_rup = d1%t_rup |
---|
215 | d2%t_lup = d1%t_lup |
---|
216 | d2%t_left = d1%t_left |
---|
217 | d2%t_ldown = d1%t_ldown |
---|
218 | d2%t_rdown = d1%t_rdown |
---|
219 | |
---|
220 | d2%u_right = d1%u_right |
---|
221 | d2%u_rup = d1%u_rup |
---|
222 | d2%u_lup = d1%u_lup |
---|
223 | d2%u_left = d1%u_left |
---|
224 | d2%u_ldown = d1%u_ldown |
---|
225 | d2%u_rdown = d1%u_rdown |
---|
226 | |
---|
227 | d2%z_rup = d1%z_rup |
---|
228 | d2%z_up = d1%z_up |
---|
229 | d2%z_lup = d1%z_lup |
---|
230 | d2%z_ldown = d1%z_ldown |
---|
231 | d2%z_down = d1%z_down |
---|
232 | d2%z_rdown = d1%z_rdown |
---|
233 | |
---|
234 | d2%t_pos = d1%t_pos |
---|
235 | d2%u_pos = d1%u_pos |
---|
236 | d2%z_pos = d1%z_pos |
---|
237 | |
---|
238 | END SUBROUTINE copy_domain |
---|
239 | |
---|
240 | |
---|
241 | SUBROUTINE assign_cell |
---|
242 | USE metric |
---|
243 | USE mpipara |
---|
244 | USE ioipsl |
---|
245 | IMPLICIT NONE |
---|
246 | INTEGER :: ind_d,ind,ind2,e,v |
---|
247 | INTEGER :: nf,nf2 |
---|
248 | INTEGER :: i,j,k,ii,jj |
---|
249 | TYPE(t_domain),POINTER :: d |
---|
250 | INTEGER :: delta |
---|
251 | INTEGER :: nbp, nn, M |
---|
252 | REAL :: rn |
---|
253 | INTEGER, ALLOCATABLE :: nb_own(:) |
---|
254 | INTEGER :: mean_own, side |
---|
255 | |
---|
256 | ALLOCATE(nb_own(0:ndomain_glo)) |
---|
257 | nb_own(:)=0 |
---|
258 | |
---|
259 | DO ind_d=1,ndomain_glo |
---|
260 | d=>domain_glo(ind_d) |
---|
261 | nf=d%face |
---|
262 | DO j=d%jj_begin,d%jj_end |
---|
263 | DO i=d%ii_begin,d%ii_end |
---|
264 | ii=d%ii_begin_glo-d%ii_begin+i |
---|
265 | jj=d%jj_begin_glo-d%jj_begin+j |
---|
266 | ind=vertex_glo(ii,jj,nf)%ind |
---|
267 | cell_glo(ind)%assign_domain=0 |
---|
268 | ENDDO |
---|
269 | ENDDO |
---|
270 | ENDDO |
---|
271 | |
---|
272 | |
---|
273 | |
---|
274 | nbp=0 |
---|
275 | DO ind_d=1,ndomain_glo |
---|
276 | d=>domain_glo(ind_d) |
---|
277 | nf=d%face |
---|
278 | DO j=d%jj_begin,d%jj_end |
---|
279 | DO i=d%ii_begin,d%ii_end |
---|
280 | ii=d%ii_begin_glo-d%ii_begin+i |
---|
281 | jj=d%jj_begin_glo-d%jj_begin+j |
---|
282 | ind=vertex_glo(ii,jj,nf)%ind |
---|
283 | delta=vertex_glo(ii,jj,nf)%delta |
---|
284 | IF (cell_glo(ind)%assign_face==nf) THEN |
---|
285 | nb_own(cell_glo(ind)%assign_domain)=nb_own(cell_glo(ind)%assign_domain)-1 |
---|
286 | nb_own(ind_d)=nb_own(ind_d)+1 |
---|
287 | cell_glo(ind)%assign_domain=ind_d |
---|
288 | cell_glo(ind)%assign_i=i |
---|
289 | cell_glo(ind)%assign_j=j |
---|
290 | ENDIF |
---|
291 | |
---|
292 | IF ( i+1 <= d%ii_end ) CALL assign_edge(ind_d,ind,i,j,delta,0) |
---|
293 | IF ( j+1 <= d%jj_end ) CALL assign_edge(ind_d,ind,i,j,delta,1) |
---|
294 | IF ( i-1 >= d%ii_begin .AND. j+1<=d%jj_end ) CALL assign_edge(ind_d,ind,i,j,delta,2) |
---|
295 | IF ( i-1 >= d%ii_begin ) CALL assign_edge(ind_d,ind,i,j,delta,3) |
---|
296 | IF ( j-1 >= d%jj_begin ) CALL assign_edge(ind_d,ind,i,j,delta,4) |
---|
297 | IF ( i+1 <= d%ii_end .AND. j-1 >=d%jj_begin ) CALL assign_edge(ind_d,ind,i,j,delta,5) |
---|
298 | |
---|
299 | IF ( i+1 <= d%ii_end .AND. j+1 <= d%jj_end) CALL assign_vertex(ind_d,ind,i,j,delta,0) |
---|
300 | IF ( i-1 >= d%ii_begin .AND. j+1 <= d%jj_end) CALL assign_vertex(ind_d,ind,i,j,delta,1) |
---|
301 | IF ( i-1 >= d%ii_begin .AND. j+1 <= d%jj_end) CALL assign_vertex(ind_d,ind,i,j,delta,2) |
---|
302 | IF ( i-1 >= d%ii_begin .AND. j-1 >= d%jj_begin) CALL assign_vertex(ind_d,ind,i,j,delta,3) |
---|
303 | IF ( i+1 <= d%ii_end .AND. j-1 >= d%jj_begin) CALL assign_vertex(ind_d,ind,i,j,delta,4) |
---|
304 | IF ( i+1 <= d%ii_end .AND. j-1 >= d%jj_begin) CALL assign_vertex(ind_d,ind,i,j,delta,5) |
---|
305 | |
---|
306 | IF (j==d%jj_begin .OR. j==d%jj_begin .OR. i==d%ii_begin .OR. i==d%ii_end) nbp=nbp+1 |
---|
307 | |
---|
308 | ENDDO |
---|
309 | ENDDO |
---|
310 | ENDDO |
---|
311 | |
---|
312 | |
---|
313 | ! dynamic load balancing for owned cells. Get ownership of a cell if local cells number < mean cell number |
---|
314 | ! use random shot on frontier |
---|
315 | |
---|
316 | mean_own=sum(nb_own(1:ndomain_glo))/ndomain_glo |
---|
317 | IF (is_mpi_master) PRINT*,"Before balance : Mean own ", sum(nb_own(1:ndomain_glo))/ndomain_glo, "Min own", minval(nb_own(1:ndomain_glo)), "Max own", maxval(nb_own(1:ndomain_glo)) |
---|
318 | ! set random seed to get reproductibility when using a different number of process |
---|
319 | |
---|
320 | CALL RANDOM_SEED(size=M) |
---|
321 | CALL RANDOM_SEED(put=(/(i,i=1,M)/)) |
---|
322 | |
---|
323 | DO nn=1,1000*nbp |
---|
324 | |
---|
325 | CALL random_number(rn) |
---|
326 | ind_d = INT(ndomain_glo*rn)+1 |
---|
327 | IF (nb_own(ind_d) >= mean_own) CYCLE |
---|
328 | |
---|
329 | d=>domain_glo(ind_d) |
---|
330 | nf=d%face |
---|
331 | |
---|
332 | CALL random_number(rn) |
---|
333 | side=INT(4*rn) |
---|
334 | IF (side==0) THEN |
---|
335 | CALL random_number(rn) |
---|
336 | i = INT((d%ii_end-d%ii_begin+1)*rn)+d%ii_begin |
---|
337 | j = d%jj_begin |
---|
338 | ELSE IF (side==1) THEN |
---|
339 | CALL random_number(rn) |
---|
340 | i = INT((d%ii_end-d%ii_begin+1)*rn)+d%ii_begin |
---|
341 | j = d%jj_end |
---|
342 | ELSE IF (side==2) THEN |
---|
343 | CALL random_number(rn) |
---|
344 | j = INT((d%jj_end-d%jj_begin+1)*rn)+d%jj_begin |
---|
345 | i = d%ii_begin |
---|
346 | ELSE IF (side==3) THEN |
---|
347 | CALL random_number(rn) |
---|
348 | j = INT((d%jj_end-d%jj_begin+1)*rn)+d%jj_begin |
---|
349 | i = d%ii_end |
---|
350 | ENDIF |
---|
351 | |
---|
352 | ii=d%ii_begin_glo-d%ii_begin+i |
---|
353 | jj=d%jj_begin_glo-d%jj_begin+j |
---|
354 | ind=vertex_glo(ii,jj,nf)%ind |
---|
355 | delta=vertex_glo(ii,jj,nf)%delta |
---|
356 | IF (cell_glo(ind)%assign_face==nf) THEN |
---|
357 | nb_own(cell_glo(ind)%assign_domain)=nb_own(cell_glo(ind)%assign_domain)-1 |
---|
358 | nb_own(ind_d)=nb_own(ind_d)+1 |
---|
359 | cell_glo(ind)%assign_domain=ind_d |
---|
360 | cell_glo(ind)%assign_i=i |
---|
361 | cell_glo(ind)%assign_j=j |
---|
362 | ENDIF |
---|
363 | |
---|
364 | ENDDO |
---|
365 | |
---|
366 | IF (is_mpi_master) PRINT*,"After balance :Mean own ", sum(nb_own(1:ndomain_glo))/ndomain_glo, "Min own", minval(nb_own(1:ndomain_glo)), "Max own", maxval(nb_own(1:ndomain_glo)) |
---|
367 | |
---|
368 | |
---|
369 | DO ind_d=1,ndomain_glo |
---|
370 | d=>domain_glo(ind_d) |
---|
371 | nf=d%face |
---|
372 | DO j=d%jj_begin-1,d%jj_end+1 |
---|
373 | DO i=d%ii_begin-1,d%ii_end+1 |
---|
374 | ii=d%ii_begin_glo-d%ii_begin+i |
---|
375 | jj=d%jj_begin_glo-d%jj_begin+j |
---|
376 | ind=vertex_glo(ii,jj,nf)%ind |
---|
377 | d%assign_cell_glo(i,j) = ind |
---|
378 | d%assign_domain(i,j)=cell_glo(ind)%assign_domain |
---|
379 | d%assign_i(i,j)=cell_glo(ind)%assign_i |
---|
380 | d%assign_j(i,j)=cell_glo(ind)%assign_j |
---|
381 | delta=vertex_glo(ii,jj,nf)%delta |
---|
382 | d%delta(i,j)=vertex_glo(ii,jj,nf)%delta |
---|
383 | DO k=0,5 |
---|
384 | ind2=vertex_glo(ii,jj,nf)%neighbour(k) |
---|
385 | d%neighbour(:,k,i,j)=cell_glo(ind2)%xyz(:) |
---|
386 | |
---|
387 | d%ne(k,i,j)=1-2*MOD(k,2) |
---|
388 | |
---|
389 | e=cell_glo(ind)%edge(MOD(k+delta+6,6)) |
---|
390 | d%edge_assign_domain(k,i,j)=edge_glo(e)%assign_domain |
---|
391 | d%edge_assign_i(k,i,j)=edge_glo(e)%assign_i |
---|
392 | d%edge_assign_j(k,i,j)=edge_glo(e)%assign_j |
---|
393 | d%edge_assign_pos(k,i,j)=edge_glo(e)%assign_pos |
---|
394 | nf2=domain_glo(edge_glo(e)%assign_domain)%face |
---|
395 | d%edge_assign_sign(k,i,j)=1-2*MOD(12+tab_index(nf,nf2,0),2) |
---|
396 | IF (MOD(6+k+tab_index(nf,nf2,0),6)/=edge_glo(e)%assign_pos .AND. MOD(6+k+tab_index(nf,nf2,0),6) & |
---|
397 | /= MOD(edge_glo(e)%assign_pos+3,6)) THEN |
---|
398 | d%edge_assign_sign(k,i,j)=-d%edge_assign_sign(k,i,j) |
---|
399 | ENDIF |
---|
400 | |
---|
401 | v=cell_glo(ind)%vertex(MOD(k+delta+6,6)) |
---|
402 | d%vertex_assign_domain(k,i,j)=vertices_glo(v)%assign_domain |
---|
403 | d%vertex_assign_i(k,i,j)=vertices_glo(v)%assign_i |
---|
404 | d%vertex_assign_j(k,i,j)=vertices_glo(v)%assign_j |
---|
405 | d%vertex_assign_pos(k,i,j)=vertices_glo(v)%assign_pos |
---|
406 | |
---|
407 | ENDDO |
---|
408 | d%xyz(:,i,j)=cell_glo(ind)%xyz(:) |
---|
409 | IF (d%assign_domain(i,j)==ind_d) THEN |
---|
410 | d%own(i,j)=.TRUE. |
---|
411 | ELSE |
---|
412 | d%own(i,j)=.FALSE. |
---|
413 | ENDIF |
---|
414 | ENDDO |
---|
415 | ENDDO |
---|
416 | ENDDO |
---|
417 | |
---|
418 | CONTAINS |
---|
419 | |
---|
420 | SUBROUTINE assign_edge(ind_d,ind,i,j,delta,k) |
---|
421 | INTEGER :: ind_d,ind,i,j,delta,k |
---|
422 | INTEGER :: e |
---|
423 | e=cell_glo(ind)%edge(MOD(k+delta+6,6)) |
---|
424 | edge_glo(e)%assign_domain=ind_d |
---|
425 | edge_glo(e)%assign_i=i |
---|
426 | edge_glo(e)%assign_j=j |
---|
427 | edge_glo(e)%assign_pos=k |
---|
428 | edge_glo(e)%assign_delta=delta |
---|
429 | |
---|
430 | END SUBROUTINE assign_edge |
---|
431 | |
---|
432 | SUBROUTINE assign_vertex(ind_d,ind,i,j,delta,k) |
---|
433 | INTEGER :: ind_d,ind,i,j,delta,k |
---|
434 | INTEGER :: e |
---|
435 | |
---|
436 | e=cell_glo(ind)%vertex(MOD(k+delta+6,6)) |
---|
437 | vertices_glo(e)%assign_domain=ind_d |
---|
438 | vertices_glo(e)%assign_i=i |
---|
439 | vertices_glo(e)%assign_j=j |
---|
440 | vertices_glo(e)%assign_pos=k |
---|
441 | vertices_glo(e)%assign_delta=delta |
---|
442 | |
---|
443 | END SUBROUTINE assign_vertex |
---|
444 | |
---|
445 | END SUBROUTINE assign_cell |
---|
446 | |
---|
447 | SUBROUTINE compute_boundary |
---|
448 | USE spherical_geom_mod |
---|
449 | IMPLICIT NONE |
---|
450 | INTEGER :: ind_d |
---|
451 | INTEGER :: i,j,k |
---|
452 | TYPE(t_domain),POINTER :: d |
---|
453 | REAL(rstd) :: ng1(3),ng2(3) |
---|
454 | |
---|
455 | DO ind_d=1,ndomain_glo |
---|
456 | d=>domain_glo(ind_d) |
---|
457 | DO j=d%jj_begin-1,d%jj_end+1 |
---|
458 | DO i=d%ii_begin-1,d%ii_end+1 |
---|
459 | DO k=0,5 |
---|
460 | ng1=d%neighbour(:,MOD(k,6),i,j) |
---|
461 | ng2=d%neighbour(:,MOD(k+1,6),i,j) |
---|
462 | IF (sqrt(sum((ng1-ng2)**2))<1e-16) ng2=d%neighbour(:,MOD(k+2,6),i,j) |
---|
463 | CALL circumcenter(d%xyz(:,i,j),ng1,ng2,d%vertex(:,k,i,j)) |
---|
464 | ENDDO |
---|
465 | ENDDO |
---|
466 | ENDDO |
---|
467 | ENDDO |
---|
468 | END SUBROUTINE compute_boundary |
---|
469 | |
---|
470 | SUBROUTINE set_neighbour_indice |
---|
471 | USE metric |
---|
472 | IMPLICIT NONE |
---|
473 | INTEGER :: ind_d |
---|
474 | TYPE(t_domain),POINTER :: d |
---|
475 | |
---|
476 | DO ind_d=1,ndomain_glo |
---|
477 | d=>domain_glo(ind_d) |
---|
478 | d%t_right=1 |
---|
479 | d%t_left=-1 |
---|
480 | d%t_rup=d%iim |
---|
481 | d%t_lup=d%iim-1 |
---|
482 | d%t_ldown=-d%iim |
---|
483 | d%t_rdown=-d%iim+1 |
---|
484 | |
---|
485 | d%u_right=0 |
---|
486 | d%u_lup=d%iim*d%jjm |
---|
487 | d%u_ldown=2*d%iim*d%jjm |
---|
488 | |
---|
489 | d%u_rup=d%t_rup+d%u_ldown |
---|
490 | d%u_left=d%t_left+d%u_right |
---|
491 | d%u_rdown=d%t_rdown+d%u_lup |
---|
492 | |
---|
493 | d%z_up=0 |
---|
494 | d%z_down=d%iim*d%jjm |
---|
495 | d%z_rup=d%t_rup+d%z_down |
---|
496 | d%z_lup=d%t_lup+d%z_down |
---|
497 | d%z_ldown=d%t_ldown+d%z_up |
---|
498 | d%z_rdown=d%t_rdown+d%z_up |
---|
499 | |
---|
500 | d%t_pos(right)=d%t_right |
---|
501 | d%t_pos(rup)=d%t_rup |
---|
502 | d%t_pos(lup)=d%t_lup |
---|
503 | d%t_pos(left)=d%t_left |
---|
504 | d%t_pos(ldown)=d%t_ldown |
---|
505 | d%t_pos(rdown)=d%t_rdown |
---|
506 | |
---|
507 | d%u_pos(right)=d%u_right |
---|
508 | d%u_pos(rup)=d%u_rup |
---|
509 | d%u_pos(lup)=d%u_lup |
---|
510 | d%u_pos(left)=d%u_left |
---|
511 | d%u_pos(ldown)=d%u_ldown |
---|
512 | d%u_pos(rdown)=d%u_rdown |
---|
513 | |
---|
514 | d%z_pos(vrup)=d%z_rup |
---|
515 | d%z_pos(vup)=d%z_up |
---|
516 | d%z_pos(vlup)=d%z_lup |
---|
517 | d%z_pos(vldown)=d%z_ldown |
---|
518 | d%z_pos(vdown)=d%z_down |
---|
519 | d%z_pos(vrdown)=d%z_rdown |
---|
520 | |
---|
521 | ENDDO |
---|
522 | |
---|
523 | END SUBROUTINE set_neighbour_indice |
---|
524 | |
---|
525 | SUBROUTINE assign_domain |
---|
526 | USE mpipara |
---|
527 | USE grid_param |
---|
528 | IMPLICIT NONE |
---|
529 | INTEGER :: nb_domain(0:mpi_size-1) |
---|
530 | INTEGER :: rank, ind,ind_glo |
---|
531 | INTEGER :: block_j,jb,i,j,nd_glo,n,nf |
---|
532 | LOGICAL :: exit |
---|
533 | |
---|
534 | DO rank=0,mpi_size-1 |
---|
535 | nb_domain(rank)=ndomain_glo/mpi_size |
---|
536 | IF ( rank < MOD(ndomain_glo,mpi_size) ) nb_domain(rank)=nb_domain(rank)+1 |
---|
537 | ENDDO |
---|
538 | |
---|
539 | ndomain=nb_domain(mpi_rank) |
---|
540 | ALLOCATE(domain(ndomain)) |
---|
541 | ALLOCATE(domloc_glo_ind(ndomain)) |
---|
542 | |
---|
543 | |
---|
544 | block_j=INT(sqrt(nsplit_i*nsplit_j*nb_face*1./mpi_size)) |
---|
545 | exit=.FALSE. |
---|
546 | jb=1 |
---|
547 | i=1 |
---|
548 | j=1 |
---|
549 | ind=1 |
---|
550 | nd_glo=0 |
---|
551 | rank=0 |
---|
552 | DO WHILE (.NOT. exit) |
---|
553 | |
---|
554 | IF (j==MIN(jb+block_j,nsplit_j*nb_face+1)) THEN |
---|
555 | j=jb |
---|
556 | i=i+1 |
---|
557 | ENDIF |
---|
558 | |
---|
559 | IF (i>nsplit_i) THEN |
---|
560 | i=1 |
---|
561 | jb=jb+block_j |
---|
562 | j=jb |
---|
563 | ENDIF |
---|
564 | |
---|
565 | IF (ind>nb_domain(rank)) THEN |
---|
566 | rank=rank+1 |
---|
567 | ind=1 |
---|
568 | ENDIF |
---|
569 | ind_glo=(j-1)*nsplit_i+i |
---|
570 | |
---|
571 | nd_glo=nd_glo+1 |
---|
572 | IF (nd_glo==ndomain_glo) THEN |
---|
573 | |
---|
574 | exit=.TRUE. |
---|
575 | IF (.NOT. (rank==mpi_size-1 .AND. ind==nb_domain(rank) )) THEN |
---|
576 | PRINT *, "Distribution problem in assign_domain" |
---|
577 | STOP |
---|
578 | ENDIF |
---|
579 | |
---|
580 | ENDIF |
---|
581 | |
---|
582 | domglo_rank(ind_glo)=rank |
---|
583 | domglo_loc_ind(ind_glo)=ind |
---|
584 | IF (rank==mpi_rank) THEN |
---|
585 | CALL copy_domain(domain_glo(ind_glo),domain(ind)) |
---|
586 | domloc_glo_ind(ind)=ind_glo |
---|
587 | ENDIF |
---|
588 | |
---|
589 | j=j+1 |
---|
590 | ind=ind+1 |
---|
591 | |
---|
592 | ENDDO |
---|
593 | |
---|
594 | IF (is_mpi_master) THEN |
---|
595 | |
---|
596 | ind_glo=0 |
---|
597 | PRINT *,'' |
---|
598 | PRINT*, ' MPI PROCESS DISTRIBUTION' |
---|
599 | PRINT *,'' |
---|
600 | |
---|
601 | WRITE(*,"(' ')", ADVANCE='NO') |
---|
602 | DO n=1,nsplit_i*7-1 |
---|
603 | WRITE(*,"('=')", ADVANCE='NO') |
---|
604 | ENDDO |
---|
605 | PRINT *,'' |
---|
606 | |
---|
607 | DO nf=1,nb_face |
---|
608 | DO j=1,nsplit_j |
---|
609 | IF (j>1) THEN |
---|
610 | WRITE(*,"(' ')", ADVANCE='NO') |
---|
611 | DO n=1,nsplit_i*7-1 |
---|
612 | WRITE(*,"('-')", ADVANCE='NO') |
---|
613 | ENDDO |
---|
614 | PRINT *,'' |
---|
615 | ENDIF |
---|
616 | |
---|
617 | WRITE(*,"('|')", ADVANCE='NO') |
---|
618 | DO i=1,nsplit_i |
---|
619 | WRITE(*,"(' ',' ',' |')",ADVANCE='NO') |
---|
620 | ENDDO |
---|
621 | PRINT *,'' |
---|
622 | |
---|
623 | WRITE(*,"('|')", ADVANCE='NO') |
---|
624 | DO i=1,nsplit_i |
---|
625 | ind_glo=ind_glo+1 |
---|
626 | WRITE(*,"(' ',i4.4 ,' |')",ADVANCE='NO') domglo_rank(ind_glo) |
---|
627 | END DO |
---|
628 | PRINT *,'' |
---|
629 | |
---|
630 | WRITE(*,"('|')", ADVANCE='NO') |
---|
631 | DO i=1,nsplit_i |
---|
632 | WRITE(*,"(' ',' ',' |')",ADVANCE='NO') |
---|
633 | ENDDO |
---|
634 | PRINT *,'' |
---|
635 | |
---|
636 | ENDDO |
---|
637 | |
---|
638 | WRITE(*,"(' ')", ADVANCE='NO') |
---|
639 | DO n=1,nsplit_i*7-1 |
---|
640 | WRITE(*,"('=')", ADVANCE='NO') |
---|
641 | ENDDO |
---|
642 | PRINT *,'' |
---|
643 | ENDDO |
---|
644 | ENDIF |
---|
645 | |
---|
646 | ! rank=0 |
---|
647 | ! ind=0 |
---|
648 | ! DO ind_glo=1,ndomain_glo |
---|
649 | ! ind=ind+1 |
---|
650 | ! domglo_rank(ind_glo)=rank |
---|
651 | ! domglo_loc_ind(ind_glo)=ind |
---|
652 | ! IF (rank==mpi_rank) THEN |
---|
653 | ! CALL copy_domain(domain_glo(ind_glo),domain(ind)) |
---|
654 | ! domloc_glo_ind(ind)=ind_glo |
---|
655 | ! ENDIF |
---|
656 | ! |
---|
657 | ! IF (ind==nb_domain(rank)) THEN |
---|
658 | ! rank=rank+1 |
---|
659 | ! ind=0 |
---|
660 | ! ENDIF |
---|
661 | ! ENDDO |
---|
662 | |
---|
663 | !$OMP PARALLEL |
---|
664 | CALL assign_domain_omp |
---|
665 | !$OMP END PARALLEL |
---|
666 | |
---|
667 | |
---|
668 | END SUBROUTINE assign_domain |
---|
669 | |
---|
670 | SUBROUTINE assign_domain_omp |
---|
671 | USE omp_para |
---|
672 | USE mpipara |
---|
673 | IMPLICIT NONE |
---|
674 | INTEGER :: nb_domain |
---|
675 | INTEGER :: rank, ind, i |
---|
676 | |
---|
677 | ALLOCATE(assigned_domain(ndomain)) |
---|
678 | |
---|
679 | ind=0 |
---|
680 | DO rank=0,omp_domain_size-1 |
---|
681 | nb_domain=ndomain/omp_domain_size |
---|
682 | IF ( rank < MOD(ndomain,omp_domain_size) ) nb_domain=nb_domain+1 |
---|
683 | |
---|
684 | DO i=1,nb_domain |
---|
685 | ind=ind+1 |
---|
686 | IF (rank==omp_domain_rank) THEN |
---|
687 | assigned_domain(ind)=.TRUE. |
---|
688 | WRITE(*,'(A,I6.6,A,I4.4,A,I4.4,A,I8.8)') "Rank ",mpi_rank," task ",rank," local domain ",ind, & |
---|
689 | " global domain ",domloc_glo_ind(ind) |
---|
690 | ELSE |
---|
691 | assigned_domain(ind)=.FALSE. |
---|
692 | ENDIF |
---|
693 | ENDDO |
---|
694 | |
---|
695 | ENDDO |
---|
696 | |
---|
697 | END SUBROUTINE assign_domain_omp |
---|
698 | |
---|
699 | |
---|
700 | |
---|
701 | SUBROUTINE compute_domain |
---|
702 | IMPLICIT NONE |
---|
703 | CALL init_domain_param |
---|
704 | CALL create_domain |
---|
705 | CALL assign_cell |
---|
706 | CALL compute_boundary |
---|
707 | CALL set_neighbour_indice |
---|
708 | CALL assign_domain |
---|
709 | |
---|
710 | END SUBROUTINE compute_domain |
---|
711 | |
---|
712 | END MODULE domain_mod |
---|
713 | |
---|