48 PROGRAM test_perf_stripes
56 USE ftest_common,
ONLY: finish_mpi, init_mpi, timer, treset, tstart, &
57 tstop, treport, id_map, test_abort, factorize, regular_deco, &
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
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
82 CHARACTER(len=10) :: grid_label
85 INTEGER :: p_ioff, p_joff
86 INTEGER :: nprocx, nprocy
89 INTEGER :: mype, mypx, mypy
92 INTEGER,
ALLOCATABLE :: g_id(:,:)
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
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.
107 CHARACTER(len=*),
PARAMETER :: filename =
'test_perf_stripes.f90'
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
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')
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')
131 CALL treset(t_redist_3d_wb,
'redist_3d_wb')
132 CALL treset(t_exch_3d_wb,
'exch_3d_wb')
141 ALLOCATE(fval_3d(nlev,ie,je), gval_3d(nlev,ie,je))
147 CALL get_window(g_id, loc_id_2d)
150 CALL def_exchange(g_id, g_tpex)
154 CALL get_window(g_tpex, 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)
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)
169 fval_2d = int(loc_id_2d)
170 CALL tstart(t_exch_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__)
178 CALL id_map(pos3d_surf)
179 CALL gen_pos3d_surf(pos3d_surf)
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)
190 CALL tstart(t_exch_surf)
192 reshape(fval_2d, (/ 1, ie, je /)), gval_3d)
193 CALL tstop(t_exch_surf)
196 IF (cmp_arrays(gval_3d(1, :, :), loc_tpex_2d)) &
197 CALL test_abort(
'surface check failed', filename, __line__)
201 IF (any(gval_3d(2, :, :) /= -1)) &
202 CALL test_abort(
'surface check failed', filename, __line__)
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)
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)
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)
227 fval_3d = int(loc_id_3d)
229 CALL tstart(t_exch_3d)
231 CALL tstop(t_exch_3d)
236 IF (cmp_arrays(gval_3d, loc_tpex_3d)) &
237 CALL test_abort(
'3D array eqivalence test failed', filename, __line__)
242 CALL gen_stripes(loc_id_3d, loc_id_3d_ws)
243 CALL gen_stripes(loc_tpex_3d, loc_tpex_3d_ws)
248 CALL tstart(t_redist_3d_ws)
250 CALL tstop(t_redist_3d_ws)
253 fval_3d = int(loc_id_3d)
256 CALL tstart(t_exch_3d_ws)
258 CALL tstop(t_exch_3d_ws)
261 IF (cmp_arrays(gval_3d, loc_tpex_3d)) &
262 CALL test_abort(
'3D array eqivalence test (using stripes) failed', &
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)
270 fval_3d = int(loc_id_3d)
272 CALL tstart(t_exch_3d_wb)
274 CALL tstop(t_exch_3d_wb)
279 IF (cmp_arrays(gval_3d, loc_tpex_3d)) &
280 CALL test_abort(
'3D array eqivalence test after redist failed', &
294 IF (verbose)
WRITE(0,*)
'timer report for nprocs=',nprocs
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)
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)
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)
313 DEALLOCATE(loc_tpex_3d, loc_id_3d, fval_2d, gval_2d, gval_3d)
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
324 INTEGER :: block_disp(ie,je), block_size(ie,je)
329 block_disp(i,j) = ( (j-1) * ie + i - 1 ) * nlev
330 block_size(i,j) = nlev
335 SIZE(block_size), block_disp, block_size,
SIZE(block_size),dt)
337 END SUBROUTINE gen_redist_3d_wb
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(:,:,:)
347 SELECT CASE(inflate_pos)
349 ALLOCATE(idx_3d(ke, ie, je))
353 idx_3d(k,i,j) = int(k + (idx_2d(i,j)-1) * ke, xt_int_kind)
358 ALLOCATE(idx_3d(ie, je, ke))
362 idx_3d(i,j,k) = int(idx_2d(i,j) + (k-1) * g_ie * g_je, xt_int_kind)
367 CALL test_abort(context//
' unsupported inflate position', &
371 END SUBROUTINE inflate_idx
373 SUBROUTINE gen_pos3d_surf(pos)
374 INTEGER,
INTENT(inout) :: pos(:,:)
380 INTEGER :: ii,jj, i,j,k, p,q
388 q = k + (i + j*ie)*nlev
393 END SUBROUTINE gen_pos3d_surf
396 CHARACTER(len=*),
PARAMETER :: context =
'init_all: '
398 CHARACTER(len=20) :: grid_str
402 CALL get_environment_variable(
'YAXT_TEST_PERF_GRID', grid_str)
406 SELECT CASE (trim(adjustl(grid_str)))
408 grid_kind = grid_kind_toy
413 grid_kind = grid_kind_tp10
418 grid_kind = grid_kind_tp04
423 grid_kind = grid_kind_tp6m
428 grid_kind = grid_kind_test
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__)
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__)
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
453 mypx = mod(mype, nprocx)
458 ALLOCATE(g_id(g_ie, g_je), g_tpex(g_ie, g_je))
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))
466 loc_id_2d = int(undef_int, xt_int_kind)
467 loc_tpex_2d = int(undef_int, xt_int_kind)
469 pos3d_surf = undef_int
471 END SUBROUTINE init_all
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
480 IF (send_dt /= recv_dt) &
481 CALL test_abort(
'gen_redist: (send_dt /= recv_dt) unsupported', &
486 END SUBROUTINE gen_redist
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
496 IF (send_dt /= recv_dt) &
497 CALL test_abort(
'gen_off_redist: (send_dt /= recv_dt) unsupported', &
502 END SUBROUTINE gen_off_redist
504 SUBROUTINE get_window(gval, win)
505 INTEGER,
INTENT(in) :: gval(:,:)
506 INTEGER(xt_int_kind),
INTENT(out) :: win(:,:)
508 INTEGER :: i, j, ig, jg
514 win(i,j) = int(gval(ig,jg), xt_int_kind)
518 END SUBROUTINE get_window
520 SUBROUTINE gen_stripes(local_idx, local_stripes)
521 CHARACTER(len=*),
PARAMETER :: context =
'gen_stripes: '
523 INTEGER(xt_int_kind),
INTENT(in) :: local_idx(:,:,:)
524 TYPE(Xt_idxlist),
INTENT(out) :: local_stripes
526 TYPE(xt_stripe),
ALLOCATABLE :: stripes(:,:)
527 INTEGER :: i, j, k, ni, nj, nk
530 nk =
SIZE(local_idx,1)
531 ni =
SIZE(local_idx,2)
532 nj =
SIZE(local_idx,3)
534 ALLOCATE(stripes(ni,nj))
539 stripes(i,j) = xt_stripe(local_idx(1,i,j), 1_xt_int_kind, nk)
541 IF (local_idx(1,i,j)-1+k /= local_idx(k,i,j)) &
542 CALL test_abort(context//
'stripe condition violated', &
550 END SUBROUTINE gen_stripes
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
557 TYPE(Xt_idxlist) :: src_idxlist, dst_idxlist
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))
566 END SUBROUTINE gen_xmap_2d
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
573 TYPE(Xt_idxlist) :: src_idxlist, dst_idxlist
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))
582 END SUBROUTINE gen_xmap_3d
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.
591 INTEGER :: g_core_is, g_core_ie, g_core_js, g_core_je
592 INTEGER :: north_halo
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
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)
605 IF (with_north_halo)
THEN
608 IF (increased_north_halo)
THEN
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', &
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))
627 DO i = nhalo+1, g_ie-nhalo
628 g_tpex(i,j) = g_id(i,j)
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)
644 g_tpex(g_core_is-i,j) = g_tpex(g_core_ie+(1-i),j)
647 g_tpex(g_core_ie+i,j) = g_tpex(nhalo+i,j)
651 CALL check_g_idx (g_tpex)
653 END SUBROUTINE def_exchange
655 SUBROUTINE check_g_idx(gidx)
656 INTEGER,
INTENT(in) :: gidx(:,:)
658 IF (any(gidx == undef_index))
THEN
659 CALL test_abort(
'check_g_idx: check failed', filename, __line__)
661 END SUBROUTINE check_g_idx
664 INTEGER :: cx0(0:nprocx-1), cxn(0:nprocx-1)
665 INTEGER :: cy0(0:nprocy-1), cyn(0:nprocy-1)
669 CALL regular_deco(g_ie-2*nhalo, cx0, cxn)
673 CALL regular_deco(g_je-2*nhalo, cy0, cyn)
676 ie = cxn(mypx) + 2*nhalo
677 je = cyn(mypy) + 2*nhalo
683 END PROGRAM test_perf_stripes
void xt_initialize(MPI_Comm default_comm)
void xt_idxlist_delete(Xt_idxlist idxlist)
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)
void xt_redist_delete(Xt_redist redist)
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
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)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)