Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_perf_stripes.f90
1
12
13!
14! Keywords:
15! Maintainer: Jörg Behrens <behrens@dkrz.de>
16! Moritz Hanke <hanke@dkrz.de>
17! Thomas Jahns <jahns@dkrz.de>
18! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
19!
20! Redistribution and use in source and binary forms, with or without
21! modification, are permitted provided that the following conditions are
22! met:
23!
24! Redistributions of source code must retain the above copyright notice,
25! this list of conditions and the following disclaimer.
26!
27! Redistributions in binary form must reproduce the above copyright
28! notice, this list of conditions and the following disclaimer in the
29! documentation and/or other materials provided with the distribution.
30!
31! Neither the name of the DKRZ GmbH nor the names of its contributors
32! may be used to endorse or promote products derived from this software
33! without specific prior written permission.
34!
35! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
36! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
37! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
38! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
39! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
40! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
41! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
42! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
43! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
44! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
45! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
46!
47#include "fc_feature_defs.inc"
48PROGRAM test_perf_stripes
49 USE mpi
50 USE yaxt, ONLY: xt_idxlist, xt_idxlist_delete, xt_idxvec_new, &
55
56 USE ftest_common, ONLY: finish_mpi, init_mpi, timer, treset, tstart, &
57 tstop, treport, id_map, test_abort, factorize, regular_deco, &
58 cmp_arrays
59
60 ! PGI compilers up to at least version 15 do not handle generic
61 ! interfaces correctly
62#if defined __PGI
63 USE xt_redist_int_i2, ONLY: xt_redist_s_exchange
64 USE xt_redist_int_i4, ONLY: xt_redist_s_exchange
65 USE xt_redist_int_i8, ONLY: xt_redist_s_exchange
66#endif
67 IMPLICIT NONE
68 ! global extents including halos:
69
70 INTEGER, PARAMETER :: nlev = 20
71 INTEGER, PARAMETER :: undef_int = - 1
72 INTEGER(xt_int_kind), PARAMETER :: undef_index = -1
73 INTEGER, PARAMETER :: nhalo = 1 ! 1dim. halo border size
74
75 INTEGER, PARAMETER :: grid_kind_test = 1
76 INTEGER, PARAMETER :: grid_kind_toy = 2
77 INTEGER, PARAMETER :: grid_kind_tp10 = 3
78 INTEGER, PARAMETER :: grid_kind_tp04 = 4
79 INTEGER, PARAMETER :: grid_kind_tp6M = 5
80 INTEGER :: grid_kind = grid_kind_test
81
82 CHARACTER(len=10) :: grid_label
83 INTEGER :: g_ie, g_je ! global domain extents
84 INTEGER :: ie, je, ke ! local extents, including halos
85 INTEGER :: p_ioff, p_joff ! offsets within global domain
86 INTEGER :: nprocx, nprocy ! process space extents
87 INTEGER :: nprocs ! == nprocx*nprocy
88 ! process rank, process coords within (0:, 0:) process space
89 INTEGER :: mype, mypx, mypy
90 LOGICAL :: lroot ! true only for proc 0
91
92 INTEGER, ALLOCATABLE :: g_id(:,:) ! global id
93 ! global "tripolar-like" toy bounds exchange
94 INTEGER, ALLOCATABLE :: g_tpex(:, :)
95 TYPE(xt_xmap) :: xmap_tpex_2d, xmap_tpex_3d, xmap_tpex_3d_ws
96 TYPE(xt_redist) :: redist_tpex_2d, redist_surf_tpex_2d, redist_tpex_3d, &
97 redist_tpex_3d_ws, redist_tpex_3d_wb
98 TYPE(Xt_idxlist) :: loc_id_3d_ws, loc_tpex_3d_ws
99
100 INTEGER(xt_int_kind), ALLOCATABLE :: loc_id_2d(:,:), loc_tpex_2d(:,:)
101 INTEGER(xt_int_kind), ALLOCATABLE :: loc_id_3d(:,:,:), loc_tpex_3d(:,:,:)
102 INTEGER, ALLOCATABLE :: fval_2d(:,:), gval_2d(:,:)
103 INTEGER, ALLOCATABLE :: fval_3d(:,:,:), gval_3d(:,:,:)
104 INTEGER, ALLOCATABLE :: id_pos(:,:), pos3d_surf(:,:)
105 LOGICAL, PARAMETER :: full_test = .true.
106 LOGICAL :: verbose
107 CHARACTER(len=*), PARAMETER :: filename = 'test_perf_stripes.f90'
108
109 TYPE(timer) :: t_all, t_surf_redist, t_exch_surf
110 TYPE(timer) :: t_xmap_2d, t_redist_2d, t_exch_2d
111 TYPE(timer) :: t_xmap_3d, t_redist_3d, t_exch_3d
112 TYPE(timer) :: t_xmap_3d_ws, t_redist_3d_ws, t_exch_3d_ws, t_exch_3d_wb
113 TYPE(timer) :: t_redist_3d_wb
114
115 !WRITE(0,*) '(debug) test_perf_stripes: verbose=', verbose
116
117 CALL treset(t_all, 'all')
118 CALL treset(t_surf_redist, 'surf_redist')
119 CALL treset(t_exch_surf, 'exch_surf')
120 CALL treset(t_xmap_2d, 'xmap_2d')
121 CALL treset(t_redist_2d, 'redist_2d')
122 CALL treset(t_exch_2d, 'exch_2d')
123 CALL treset(t_xmap_3d, 'xmap_3d')
124 CALL treset(t_redist_3d, 'redist_3d')
125 CALL treset(t_exch_3d, 'exch_3d')
126
127 CALL treset(t_xmap_3d_ws, 'xmap_3d_ws')
128 CALL treset(t_redist_3d_ws, 'redist_3d_ws')
129 CALL treset(t_exch_3d_ws, 'exch_3d_ws')
130
131 CALL treset(t_redist_3d_wb, 'redist_3d_wb')
132 CALL treset(t_exch_3d_wb, 'exch_3d_wb')
133
134 CALL init_mpi
135
136 CALL tstart(t_all)
137
138 ! mpi & decomposition & allocate mem:
139 CALL init_all
140
141 ALLOCATE(fval_3d(nlev,ie,je), gval_3d(nlev,ie,je))
142
143 ! full global index space:
144 CALL id_map(g_id)
145
146 ! local window of global index space:
147 CALL get_window(g_id, loc_id_2d)
148
149 ! define bounds exchange for full global index space
150 CALL def_exchange(g_id, g_tpex)
151 !g_tpex = g_id
152 DEALLOCATE(g_id)
153 ! local window of global bounds exchange:
154 CALL get_window(g_tpex, loc_tpex_2d)
155 DEALLOCATE(g_tpex)
156
157 IF (full_test) THEN
158 ! xmap: loc_id_2d -> loc_tpex_2d
159 CALL tstart(t_xmap_2d)
160 CALL gen_xmap_2d(loc_id_2d, loc_tpex_2d, xmap_tpex_2d)
161 CALL tstop(t_xmap_2d)
162
163 ! transposition: loc_id_2d:data -> loc_tpex_2d:data
164 CALL tstart(t_redist_2d)
165 CALL gen_redist(xmap_tpex_2d, mpi_integer, mpi_integer, redist_tpex_2d)
166 CALL tstop(t_redist_2d)
167
168 ! test 2d-to-2d transposition:
169 fval_2d = int(loc_id_2d)
170 CALL tstart(t_exch_2d)
171 CALL xt_redist_s_exchange(redist_tpex_2d, fval_2d, gval_2d)
172 CALL tstop(t_exch_2d)
173 IF (cmp_arrays(gval_2d, loc_tpex_2d)) &
174 CALL test_abort('array eqivalence test failed', filename, __line__)
175
176 ! define positions of surface elements within (k,i,j) array
177 CALL id_map(id_pos)
178 CALL id_map(pos3d_surf)
179 CALL gen_pos3d_surf(pos3d_surf)
180
181 ! generate surface transposition:
182 CALL tstart(t_surf_redist)
183 CALL gen_off_redist(xmap_tpex_2d, mpi_integer, id_pos(:,:)-1, &
184 mpi_integer, pos3d_surf(:,:)-1, redist_surf_tpex_2d)
185 CALL tstop(t_surf_redist)
186 DEALLOCATE(id_pos, pos3d_surf)
187
188 ! 2d to surface boundsexchange:
189 gval_3d = -1
190 CALL tstart(t_exch_surf)
191 CALL xt_redist_s_exchange(redist_surf_tpex_2d, &
192 reshape(fval_2d, (/ 1, ie, je /)), gval_3d)
193 CALL tstop(t_exch_surf)
194
195 ! check surface:
196 IF (cmp_arrays(gval_3d(1, :, :), loc_tpex_2d)) &
197 CALL test_abort('surface check failed', filename, __line__)
198
199 IF (nlev>1) THEN
200 ! check sub surface:
201 IF (any(gval_3d(2, :, :) /= -1)) &
202 CALL test_abort('surface check failed', filename, __line__)
203 ENDIF
204 endif
205
206 ! inflate (i,j) -> (k,i,j)
207 CALL inflate_idx(1, loc_id_2d, loc_id_3d)
208 DEALLOCATE(loc_id_2d)
209 CALL inflate_idx(1, loc_tpex_2d, loc_tpex_3d)
210 DEALLOCATE(loc_tpex_2d)
211
212 IF (full_test) THEN
213
214 ! xmap: loc_id_3d -> loc_tpex_3d
215 CALL tstart(t_xmap_3d)
216 CALL gen_xmap_3d(loc_id_3d, loc_tpex_3d, xmap_tpex_3d)
217 CALL tstop(t_xmap_3d)
218
219 ! transposition: loc_id_3d:data -> loc_tpex_3d:data
220 CALL tstart(t_redist_3d)
221 CALL gen_redist(xmap_tpex_3d, mpi_integer, mpi_integer, redist_tpex_3d)
222 CALL tstop(t_redist_3d)
223
224 CALL xt_xmap_delete(xmap_tpex_3d)
225
226 ! test 3d-to-3d transposition:
227 fval_3d = int(loc_id_3d)
228 gval_3d = -1
229 CALL tstart(t_exch_3d)
230 CALL xt_redist_s_exchange(redist_tpex_3d, fval_3d, gval_3d)
231 CALL tstop(t_exch_3d)
232
233 CALL xt_redist_delete(redist_tpex_3d)
234
235 ! check 3d exchange:
236 IF (cmp_arrays(gval_3d, loc_tpex_3d)) &
237 CALL test_abort('3D array eqivalence test failed', filename, __line__)
238 endif
239
240
241 ! gen stripes, xmap, redist:
242 CALL gen_stripes(loc_id_3d, loc_id_3d_ws)
243 CALL gen_stripes(loc_tpex_3d, loc_tpex_3d_ws)
244
245 xmap_tpex_3d_ws = xt_xmap_all2all_new(loc_id_3d_ws, loc_tpex_3d_ws, &
246 mpi_comm_world)
247
248 CALL tstart(t_redist_3d_ws)
249 redist_tpex_3d_ws = xt_redist_p2p_new(xmap_tpex_3d_ws, mpi_integer)
250 CALL tstop(t_redist_3d_ws)
251
252 ! test redist_tpex_3d_ws:
253 fval_3d = int(loc_id_3d)
254 gval_3d = -1
255
256 CALL tstart(t_exch_3d_ws)
257 CALL xt_redist_s_exchange(redist_tpex_3d_ws, fval_3d, gval_3d)
258 CALL tstop(t_exch_3d_ws)
259 if (full_test) then
260 ! check 3d exchange:
261 IF (cmp_arrays(gval_3d, loc_tpex_3d)) &
262 CALL test_abort('3D array eqivalence test (using stripes) failed', &
263 filename, __line__)
264 endif
265
266 CALL tstart(t_redist_3d_wb)
267 CALL gen_redist_3d_wb(xmap_tpex_2d, mpi_integer, redist_tpex_3d_wb)
268 CALL tstop(t_redist_3d_wb)
269
270 fval_3d = int(loc_id_3d)
271 gval_3d = -1
272 CALL tstart(t_exch_3d_wb)
273 CALL xt_redist_s_exchange(redist_tpex_3d_wb, fval_3d, gval_3d)
274 CALL tstop(t_exch_3d_wb)
275
276 DEALLOCATE(fval_3d)
277 CALL xt_redist_delete(redist_tpex_3d_wb)
278
279 IF (cmp_arrays(gval_3d, loc_tpex_3d)) &
280 CALL test_abort('3D array eqivalence test after redist failed', &
281 filename, __line__)
282
283 ! cleanup:
284 IF (full_test) THEN
285 CALL xt_redist_delete(redist_tpex_3d_ws)
286 CALL xt_xmap_delete(xmap_tpex_3d_ws)
287 CALL xt_xmap_delete(xmap_tpex_2d)
288 CALL xt_redist_delete(redist_tpex_2d)
289 CALL xt_redist_delete(redist_surf_tpex_2d)
290 ENDIF
291
292 CALL tstop(t_all)
293
294 IF (verbose) WRITE(0,*) 'timer report for nprocs=',nprocs
295
296 CALL treport(t_all, trim(grid_label), mpi_comm_world)
297 CALL treport(t_surf_redist, trim(grid_label), mpi_comm_world)
298 CALL treport(t_exch_surf, trim(grid_label), mpi_comm_world)
299 CALL treport(t_xmap_2d, trim(grid_label), mpi_comm_world)
300 CALL treport(t_redist_2d, trim(grid_label), mpi_comm_world)
301 CALL treport(t_exch_2d, trim(grid_label), mpi_comm_world)
302 CALL treport(t_xmap_3d, trim(grid_label), mpi_comm_world)
303 CALL treport(t_redist_3d, trim(grid_label), mpi_comm_world)
304 CALL treport(t_exch_3d, trim(grid_label), mpi_comm_world)
305
306 CALL treport(t_xmap_3d_ws, trim(grid_label), mpi_comm_world)
307 CALL treport(t_redist_3d_ws, trim(grid_label), mpi_comm_world)
308 CALL treport(t_exch_3d_ws, trim(grid_label), mpi_comm_world)
309
310 CALL treport(t_redist_3d_wb, trim(grid_label), mpi_comm_world)
311 CALL treport(t_exch_3d_wb, trim(grid_label), mpi_comm_world)
312
313 DEALLOCATE(loc_tpex_3d, loc_id_3d, fval_2d, gval_2d, gval_3d)
314 CALL xt_finalize()
315 CALL finish_mpi
316
317CONTAINS
318
319 SUBROUTINE gen_redist_3d_wb(xmap_2d, dt, redist_3d)
320 TYPE(xt_xmap), INTENT(in) :: xmap_2d
321 INTEGER, INTENT(in) :: dt
322 TYPE(xt_redist), INTENT(out) :: redist_3d
323
324 INTEGER :: block_disp(ie,je), block_size(ie,je)
325 INTEGER :: i, j
326 ! data(k,i,j)
327 DO j = 1, je
328 DO i = 1, ie
329 block_disp(i,j) = ( (j-1) * ie + i - 1 ) * nlev
330 block_size(i,j) = nlev
331 ENDDO
332 ENDDO
333 !WRITE(0,*) '(gen_redist_3d_wb) call redist with field sizes =',ie*je
334 redist_3d = xt_redist_p2p_blocks_off_new(xmap_2d, block_disp, block_size, &
335 SIZE(block_size), block_disp, block_size, SIZE(block_size),dt)
336
337 END SUBROUTINE gen_redist_3d_wb
338
339 SUBROUTINE inflate_idx(inflate_pos, idx_2d, idx_3d)
340 CHARACTER(len=*), PARAMETER :: context = 'test_perf::inflate_idx: '
341 INTEGER, INTENT(in) :: inflate_pos
342 INTEGER(xt_int_kind), INTENT(in) :: idx_2d(:,:)
343 INTEGER(xt_int_kind), ALLOCATABLE, INTENT(out) :: idx_3d(:,:,:)
344
345 INTEGER :: i, j, k
346
347 SELECT CASE(inflate_pos)
348 CASE(1)
349 ALLOCATE(idx_3d(ke, ie, je))
350 DO j=1,je
351 DO i=1,ie
352 DO k=1,ke
353 idx_3d(k,i,j) = int(k + (idx_2d(i,j)-1) * ke, xt_int_kind)
354 ENDDO
355 ENDDO
356 ENDDO
357 CASE(3)
358 ALLOCATE(idx_3d(ie, je, ke))
359 DO k=1,ke
360 DO j=1,je
361 DO i=1,ie
362 idx_3d(i,j,k) = int(idx_2d(i,j) + (k-1) * g_ie * g_je, xt_int_kind)
363 ENDDO
364 ENDDO
365 ENDDO
366 CASE DEFAULT
367 CALL test_abort(context//' unsupported inflate position', &
368 filename, __line__)
369 END SELECT
370
371 END SUBROUTINE inflate_idx
372
373 SUBROUTINE gen_pos3d_surf(pos)
374 INTEGER, INTENT(inout) :: pos(:,:)
375
376 ! positions for zero based arrays ([k,i,j] dim order):
377 ! old pos = i + j*ie
378 ! new pos = k + (i + j*ie)*nlev
379
380 INTEGER :: ii,jj, i,j,k, p,q
381
382 k = 0 ! surface
383 DO jj=1,je
384 DO ii=1,ie
385 p = pos(ii,jj) - 1 ! shift to 0-based index
386 j = p/ie
387 i = mod(p,ie)
388 q = k + (i + j*ie)*nlev
389 pos(ii,jj) = q + 1 ! shift to 1-based index
390 ENDDO
391 ENDDO
392
393 END SUBROUTINE gen_pos3d_surf
394
395 SUBROUTINE init_all
396 CHARACTER(len=*), PARAMETER :: context = 'init_all: '
397 INTEGER :: ierror
398 CHARACTER(len=20) :: grid_str
399
400 CALL xt_initialize(mpi_comm_world)
401
402 CALL get_environment_variable('YAXT_TEST_PERF_GRID', grid_str)
403
404 verbose = .true.
405
406 SELECT CASE (trim(adjustl(grid_str)))
407 CASE('TOY')
408 grid_kind = grid_kind_toy
409 grid_label = 'TOY'
410 g_ie = 66
411 g_je = 36
412 CASE('TP10')
413 grid_kind = grid_kind_tp10
414 grid_label = 'TP10'
415 g_ie = 362
416 g_je = 192
417 CASE('TP04')
418 grid_kind = grid_kind_tp04
419 grid_label = 'TP04'
420 g_ie = 802
421 g_je = 404
422 CASE('TP6M')
423 grid_kind = grid_kind_tp6m
424 grid_label = 'TP6M'
425 g_ie = 3602
426 g_je = 2394
427 CASE default
428 grid_kind = grid_kind_test
429 grid_label = 'TEST'
430 g_ie = 32
431 g_je = 12
432 verbose = .false.
433 END SELECT
434
435 CALL mpi_comm_size(mpi_comm_world, nprocs, ierror)
436 IF (ierror /= mpi_success) &
437 CALL test_abort(context//'MPI_COMM_SIZE failed', filename, __line__)
438
439 CALL mpi_comm_rank(mpi_comm_world, mype, ierror)
440 IF (ierror /= mpi_success) &
441 CALL test_abort(context//'MPI_COMM_RANK failed', filename, __line__)
442 IF (mype==0) THEN
443 lroot = .true.
444 ELSE
445 lroot = .false.
446 verbose = .false.
447 ENDIF
448
449 CALL factorize(nprocs, nprocx, nprocy)
450 IF (lroot .AND. verbose) WRITE(0,*) 'nprocx, nprocy=',nprocx, nprocy
451 IF (lroot .AND. verbose) WRITE(0,*) 'g_ie, g_je=',g_ie, g_je
452 mypy = mype / nprocx
453 mypx = mod(mype, nprocx)
454
455 CALL deco
456 ke = nlev
457
458 ALLOCATE(g_id(g_ie, g_je), g_tpex(g_ie, g_je))
459
460 ALLOCATE(fval_2d(ie,je), gval_2d(ie,je))
461 ALLOCATE(loc_id_2d(ie,je), loc_tpex_2d(ie,je))
462 ALLOCATE(id_pos(ie,je), pos3d_surf(ie,je))
463
464 fval_2d = undef_int
465 gval_2d = undef_int
466 loc_id_2d = int(undef_int, xt_int_kind)
467 loc_tpex_2d = int(undef_int, xt_int_kind)
468 id_pos = undef_int
469 pos3d_surf = undef_int
470
471 END SUBROUTINE init_all
472
473 SUBROUTINE gen_redist(xmap, send_dt, recv_dt, redist)
474 TYPE(xt_xmap), INTENT(in) :: xmap
475 INTEGER, INTENT(in) :: send_dt, recv_dt
476 TYPE(xt_redist),INTENT(out) :: redist
477
478 INTEGER :: dt
479
480 IF (send_dt /= recv_dt) &
481 CALL test_abort('gen_redist: (send_dt /= recv_dt) unsupported', &
482 filename, __line__)
483 dt = send_dt
484 redist = xt_redist_p2p_new(xmap, dt)
485
486 END SUBROUTINE gen_redist
487
488 SUBROUTINE gen_off_redist(xmap, send_dt, send_off, recv_dt, recv_off, redist)
489 TYPE(xt_xmap), INTENT(in) :: xmap
490 INTEGER,INTENT(in) :: send_dt, recv_dt
491 INTEGER,INTENT(in) :: send_off(:,:), recv_off(:,:)
492 TYPE(xt_redist),INTENT(out) :: redist
493
494 INTEGER :: dt
495
496 IF (send_dt /= recv_dt) &
497 CALL test_abort('gen_off_redist: (send_dt /= recv_dt) unsupported', &
498 filename, __line__)
499 dt = send_dt
500
501 redist = xt_redist_p2p_off_new(xmap, send_off, recv_off, dt)
502 END SUBROUTINE gen_off_redist
503
504 SUBROUTINE get_window(gval, win)
505 INTEGER, INTENT(in) :: gval(:,:)
506 INTEGER(xt_int_kind), INTENT(out) :: win(:,:)
507
508 INTEGER :: i, j, ig, jg
509
510 DO j = 1, je
511 jg = p_joff + j
512 DO i = 1, ie
513 ig = p_ioff + i
514 win(i,j) = int(gval(ig,jg), xt_int_kind)
515 ENDDO
516 ENDDO
517
518 END SUBROUTINE get_window
519
520 SUBROUTINE gen_stripes(local_idx, local_stripes)
521 CHARACTER(len=*), PARAMETER :: context = 'gen_stripes: '
522
523 INTEGER(xt_int_kind), INTENT(in) :: local_idx(:,:,:)
524 TYPE(Xt_idxlist), INTENT(out) :: local_stripes
525
526 TYPE(xt_stripe), ALLOCATABLE :: stripes(:,:)
527 INTEGER :: i, j, k, ni, nj, nk
528
529 ! FIXME: assert nk matches xt_int_kind representable values
530 nk = SIZE(local_idx,1)
531 ni = SIZE(local_idx,2)
532 nj = SIZE(local_idx,3)
533
534 ALLOCATE(stripes(ni,nj))
535
536 DO j = 1, nj
537 DO i = 1, ni
538 ! start, nstrides, stride
539 stripes(i,j) = xt_stripe(local_idx(1,i,j), 1_xt_int_kind, nk)
540 DO k = 1, nk
541 IF (local_idx(1,i,j)-1+k /= local_idx(k,i,j)) &
542 CALL test_abort(context//'stripe condition violated', &
543 filename, __line__)
544 ENDDO
545 ENDDO
546 ENDDO
547
548 local_stripes = xt_idxstripes_new(stripes, SIZE(stripes))
549
550 END SUBROUTINE gen_stripes
551
552 SUBROUTINE gen_xmap_2d(local_src_idx, local_dst_idx, xmap)
553 INTEGER(xt_int_kind), INTENT(in) :: local_src_idx(:,:)
554 INTEGER(xt_int_kind), INTENT(in) :: local_dst_idx(:,:)
555 TYPE(xt_xmap), INTENT(out) :: xmap
556
557 TYPE(Xt_idxlist) :: src_idxlist, dst_idxlist
558
559 src_idxlist = xt_idxvec_new(local_src_idx, SIZE(local_src_idx))
560 dst_idxlist = xt_idxvec_new(local_dst_idx, SIZE(local_dst_idx))
561 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
562
563 CALL xt_idxlist_delete(src_idxlist)
564 CALL xt_idxlist_delete(dst_idxlist)
565
566 END SUBROUTINE gen_xmap_2d
567
568 SUBROUTINE gen_xmap_3d(local_src_idx, local_dst_idx, xmap)
569 INTEGER(xt_int_kind), INTENT(in) :: local_src_idx(:,:,:)
570 INTEGER(xt_int_kind), INTENT(in) :: local_dst_idx(:,:,:)
571 TYPE(xt_xmap), INTENT(out) :: xmap
572
573 TYPE(Xt_idxlist) :: src_idxlist, dst_idxlist
574
575 src_idxlist = xt_idxvec_new(local_src_idx, SIZE(local_src_idx))
576 dst_idxlist = xt_idxvec_new(local_dst_idx, SIZE(local_dst_idx))
577 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
578 CALL xt_idxlist_delete(src_idxlist)
579 CALL xt_idxlist_delete(dst_idxlist)
580
581
582 END SUBROUTINE gen_xmap_3d
583
584
585 SUBROUTINE def_exchange(g_id, g_tpex)
586 INTEGER, INTENT(in) :: g_id(:, :)
587 INTEGER, INTENT(out) :: g_tpex(:, :)
588 LOGICAL, PARAMETER :: increased_north_halo = .false.
589 LOGICAL, PARAMETER :: with_north_halo = .true.
590 INTEGER :: i, j
591 INTEGER :: g_core_is, g_core_ie, g_core_js, g_core_je
592 INTEGER :: north_halo
593
594 ! global core domain:
595 g_core_is = nhalo + 1
596 g_core_ie = g_ie-nhalo
597 g_core_js = nhalo + 1
598 g_core_je = g_je-nhalo
599
600 ! global tripolar boundsexchange:
601 g_tpex = undef_index
602 g_tpex(g_core_is:g_core_ie, g_core_js:g_core_je) &
603 = g_id(g_core_is:g_core_ie, g_core_js:g_core_je)
604
605 IF (with_north_halo) THEN
606
607 ! north inversion, (maybe with increased north halo)
608 IF (increased_north_halo) THEN
609 north_halo = nhalo+1
610 ELSE
611 north_halo = nhalo
612 ENDIF
613
614 IF (2*north_halo > g_core_je) &
615 CALL test_abort('def_exchange: grid too small (or halo too large&
616 &) for tripolar north exchange', &
617 filename, __line__)
618 DO j = 1, north_halo
619 DO i = g_core_is, g_core_ie
620 g_tpex(i,j) = g_tpex(g_core_ie + (g_core_is-i), 2*north_halo + (1-j))
621 ENDDO
622 ENDDO
623
624 ELSE
625
626 DO j = 1, nhalo
627 DO i = nhalo+1, g_ie-nhalo
628 g_tpex(i,j) = g_id(i,j)
629 ENDDO
630 ENDDO
631
632 ENDIF
633
634 ! south: no change
635 DO j = g_core_je+1, g_je
636 DO i = nhalo+1, g_ie-nhalo
637 g_tpex(i,j) = g_id(i,j)
638 ENDDO
639 ENDDO
640
641 ! PBC
642 DO j = 1, g_je
643 DO i = 1, nhalo
644 g_tpex(g_core_is-i,j) = g_tpex(g_core_ie+(1-i),j)
645 ENDDO
646 DO i = 1, nhalo
647 g_tpex(g_core_ie+i,j) = g_tpex(nhalo+i,j)
648 ENDDO
649 ENDDO
650
651 CALL check_g_idx (g_tpex)
652
653 END SUBROUTINE def_exchange
654
655 SUBROUTINE check_g_idx(gidx)
656 INTEGER,INTENT(in) :: gidx(:,:)
657
658 IF (any(gidx == undef_index)) THEN
659 CALL test_abort('check_g_idx: check failed', filename, __line__)
660 ENDIF
661 END SUBROUTINE check_g_idx
662
663 SUBROUTINE deco
664 INTEGER :: cx0(0:nprocx-1), cxn(0:nprocx-1)
665 INTEGER :: cy0(0:nprocy-1), cyn(0:nprocy-1)
666
667 cx0 = 0
668 cxn = 0
669 CALL regular_deco(g_ie-2*nhalo, cx0, cxn)
670
671 cy0 = 0
672 cyn = 0
673 CALL regular_deco(g_je-2*nhalo, cy0, cyn)
674
675 ! process local deco variables:
676 ie = cxn(mypx) + 2*nhalo
677 je = cyn(mypy) + 2*nhalo
678 p_ioff = cx0(mypx)
679 p_joff = cy0(mypy)
680
681 END SUBROUTINE deco
682
683END PROGRAM test_perf_stripes
684!
685! Local Variables:
686! f90-continuation-indent: 5
687! coding: utf-8
688! indent-tabs-mode: nil
689! show-trailing-whitespace: t
690! require-trailing-newline: t
691! End:
692!
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
Xt_idxlist xt_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition xt_idxvec.c:213
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
Definition xt_redist.c:79
Xt_redist xt_redist_p2p_off_new(Xt_xmap xmap, const int *src_offsets, const int *dst_offsets, MPI_Datatype datatype)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
Xt_redist xt_redist_p2p_blocks_off_new(Xt_xmap xmap, const int *src_block_offsets, const int *src_block_sizes, int src_block_num, const int *dst_block_offsets, const int *dst_block_sizes, int dst_block_num, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Definition xt_xmap.c:86
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)