Yet Another eXchange Tool  0.9.0
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://doc.redmine.dkrz.de/yaxt/html/
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 
48 PROGRAM test_perf_stripes
49  USE mpi
50  USE yaxt, ONLY: xt_idxlist, xt_idxlist_delete, xt_idxvec_new, &
51  xt_xmap, xt_xmap_all2all_new, xt_xmap_delete, xt_redist, &
54  xt_stripe, xt_idxstripes_new, xt_int_kind, xt_initialize, xt_finalize
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
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 
317 CONTAINS
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 
683 END 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 !
Definition: yaxt.f90:49
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
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:163
void xt_redist_delete(Xt_redist redist)
Definition: xt_redist.c:68
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
Definition: xt_redist.c:73
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:85
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)