51 & ut_transpose, ut_init_decomposition, &
54 & ut_init_transposition, xt_int_kind
55 USE ftest_common,
ONLY: finish_mpi, init_mpi, treset, tstart, tstop, &
56 treport, timer, id_map, factorize, regular_deco, set_verbose, icmp
62 INTEGER,
PARAMETER :: nlev = 30
63 INTEGER,
PARAMETER :: undef_int = (huge(undef_int)-1)/2 - 1
64 INTEGER(xt_int_kind),
PARAMETER :: undef_index = -1
65 INTEGER,
PARAMETER :: nhalo = 1
67 INTEGER,
PARAMETER :: grid_kind_test = 1
68 INTEGER,
PARAMETER :: grid_kind_toy = 2
69 INTEGER,
PARAMETER :: grid_kind_tp10 = 3
70 INTEGER,
PARAMETER :: grid_kind_tp04 = 4
71 INTEGER,
PARAMETER :: grid_kind_tp6M = 5
72 INTEGER :: grid_kind = grid_kind_test
74 CHARACTER(len=10) :: grid_label
77 INTEGER :: p_ioff, p_joff
78 INTEGER :: nprocx, nprocy
81 INTEGER :: mype, mypx, mypy
83 CHARACTER(len=*),
PARAMETER :: filename =
'test_perf.f90'
85 INTEGER,
ALLOCATABLE :: g_id(:,:)
87 INTEGER,
ALLOCATABLE :: g_tpex(:, :)
88 INTEGER :: template_tpex_2d, trans_tpex_2d
89 INTEGER :: template_tpex_3d, trans_tpex_3d
91 INTEGER,
ALLOCATABLE :: loc_id_2d(:,:), loc_tpex_2d(:,:)
92 INTEGER,
ALLOCATABLE :: loc_id_3d(:,:,:), loc_tpex_3d(:,:,:)
93 INTEGER,
ALLOCATABLE :: fval_2d(:,:), gval_2d(:,:)
94 INTEGER,
ALLOCATABLE :: fval_3d(:,:,:), gval_3d(:,:,:)
95 INTEGER,
ALLOCATABLE :: id_pos(:,:), pos3d_surf(:,:)
96 INTEGER :: surf_trans_tpex_2d
99 TYPE(timer) :: t_all, t_surf_trans, t_exch_surf
100 TYPE(timer) :: t_template_2d, t_trans_2d, t_exch_2d
101 TYPE(timer) :: t_template_3d, t_trans_3d, t_exch_3d
103 CALL treset(t_all,
'all')
104 CALL treset(t_surf_trans,
'surf_trans')
105 CALL treset(t_exch_surf,
'exch_surf')
106 CALL treset(t_template_2d,
'template_2d')
107 CALL treset(t_trans_2d,
'trans_2d')
108 CALL treset(t_exch_2d,
'exch_2d')
109 CALL treset(t_template_3d,
'template_3d')
110 CALL treset(t_trans_3d,
'trans_3d')
111 CALL treset(t_exch_3d,
'exch_3d')
124 CALL get_window(g_id, loc_id_2d)
128 CALL def_exchange(g_id, g_tpex)
131 CALL get_window(g_tpex, loc_tpex_2d)
135 CALL tstart(t_template_2d)
136 CALL gen_template_2d(loc_id_2d, loc_tpex_2d, template_tpex_2d)
137 CALL tstop(t_template_2d)
140 CALL tstart(t_trans_2d)
141 CALL gen_trans(template_tpex_2d, mpi_integer, mpi_integer, trans_tpex_2d)
142 CALL tstop(t_trans_2d)
147 CALL tstart(t_exch_2d)
148 CALL exchange2d_2d(trans_tpex_2d, fval_2d, gval_2d)
149 CALL tstop(t_exch_2d)
150 CALL icmp(
'2d to 2d check', gval_2d, loc_tpex_2d, mype)
154 CALL id_map(pos3d_surf)
155 CALL gen_pos3d_surf(pos3d_surf)
158 CALL tstart(t_surf_trans)
159 CALL gen_off_trans(template_tpex_2d, mpi_integer, id_pos(:,:)-1, &
160 mpi_integer, pos3d_surf(:,:)-1, surf_trans_tpex_2d)
161 CALL tstop(t_surf_trans)
162 DEALLOCATE(id_pos, pos3d_surf)
166 ALLOCATE(gval_3d(ie,nlev,je))
168 CALL tstart(t_exch_surf)
169 CALL exchange2d_3d(surf_trans_tpex_2d, fval_2d, gval_3d)
170 CALL tstop(t_exch_surf)
172 CALL icmp(
'surface check', gval_3d(:,1,:), loc_tpex_2d, mype)
175 CALL icmp(
'sub surface check', gval_3d(:,2,:), loc_tpex_2d*0-1, mype)
183 CALL inflate_idx(3, loc_id_2d, loc_id_3d)
184 DEALLOCATE(loc_id_2d)
185 CALL inflate_idx(3, loc_tpex_2d, loc_tpex_3d)
186 DEALLOCATE(loc_tpex_2d)
189 CALL tstart(t_template_3d)
190 CALL gen_template_3d(loc_id_3d, loc_tpex_3d, template_tpex_3d)
191 CALL tstop(t_template_3d)
194 CALL tstart(t_trans_3d)
195 CALL gen_trans(template_tpex_3d, mpi_integer, mpi_integer, trans_tpex_3d)
196 CALL tstop(t_trans_3d)
200 ALLOCATE(fval_3d(ie,je,nlev), gval_3d(ie,je,nlev))
202 CALL tstart(t_exch_3d)
203 CALL exchange3d_3d(trans_tpex_3d, fval_3d, gval_3d)
204 CALL tstop(t_exch_3d)
206 CALL icmp(
'3d to 3d check', gval_3d, loc_tpex_3d, mype)
215 IF (verbose)
WRITE(0,*)
'timer report for nprocs=',nprocs
217 CALL treport(t_all, trim(grid_label), mpi_comm_world)
218 CALL treport(t_surf_trans, trim(grid_label), mpi_comm_world)
219 CALL treport(t_exch_surf, trim(grid_label), mpi_comm_world)
220 CALL treport(t_template_2d, trim(grid_label), mpi_comm_world)
221 CALL treport(t_trans_2d, trim(grid_label), mpi_comm_world)
222 CALL treport(t_exch_2d, trim(grid_label), mpi_comm_world)
223 CALL treport(t_template_3d, trim(grid_label), mpi_comm_world)
224 CALL treport(t_trans_3d, trim(grid_label), mpi_comm_world)
225 CALL treport(t_exch_3d, trim(grid_label), mpi_comm_world)
227 DEALLOCATE(loc_tpex_3d, loc_id_3d, fval_2d, gval_2d)
233 SUBROUTINE inflate_idx(inflate_pos, idx_2d, idx_3d)
234 CHARACTER(len=*),
PARAMETER :: context =
'test_perf::inflate_idx: '
235 INTEGER,
INTENT(in) :: inflate_pos
236 INTEGER,
INTENT(in) :: idx_2d(:,:)
237 INTEGER,
ALLOCATABLE,
INTENT(out) :: idx_3d(:,:,:)
241 IF (inflate_pos == 3)
THEN
242 ALLOCATE(idx_3d(ie, je, ke))
246 idx_3d(i,j,k) = idx_2d(i,j) + (k-1) * g_ie * g_je
251 CALL ut_abort(context//
' unsupported inflate position', &
255 END SUBROUTINE inflate_idx
257 SUBROUTINE gen_pos3d_surf(pos)
258 INTEGER,
INTENT(inout) :: pos(:,:)
262 INTEGER :: ii,jj, i,j,k, p,q
270 q = i + k*ie + j*ie*nlev
275 END SUBROUTINE gen_pos3d_surf
278 CHARACTER(len=*),
PARAMETER :: context =
'init_all: '
280 CHARACTER(len=20) :: grid_str
282 CALL get_environment_variable(
'YAXT_TEST_PERF_GRID', grid_str)
286 SELECT CASE (trim(adjustl(grid_str)))
288 grid_kind = grid_kind_toy
293 grid_kind = grid_kind_tp10
298 grid_kind = grid_kind_tp04
303 grid_kind = grid_kind_tp6m
308 grid_kind = grid_kind_test
315 CALL mpi_comm_size(mpi_comm_world, nprocs, ierror)
316 IF (ierror /= mpi_success)
CALL ut_abort(context//
'MPI_COMM_SIZE failed', &
319 CALL mpi_comm_rank(mpi_comm_world, mype, ierror)
320 IF (ierror /= mpi_success)
CALL ut_abort(context//
'MPI_COMM_RANK failed', &
328 CALL set_verbose(verbose)
329 CALL factorize(nprocs, nprocx, nprocy)
330 IF (lroot .AND. verbose)
WRITE(0,*)
'nprocx, nprocy=',nprocx, nprocy
331 IF (lroot .AND. verbose)
WRITE(0,*)
'g_ie, g_je=',g_ie, g_je
333 mypx = mod(mype, nprocx)
338 ALLOCATE(g_id(g_ie, g_je), g_tpex(g_ie, g_je))
340 ALLOCATE(fval_2d(ie,je), gval_2d(ie,je))
341 ALLOCATE(loc_id_2d(ie,je), loc_tpex_2d(ie,je))
342 ALLOCATE(id_pos(ie,je), pos3d_surf(ie,je))
346 loc_id_2d = undef_int
347 loc_tpex_2d = undef_int
349 pos3d_surf = undef_int
351 CALL ut_init(decomp_size=30, comm_tmpl_size=30, comm_size=30, &
354 END SUBROUTINE init_all
356 SUBROUTINE exchange2d_2d(itrans, f, g)
357 INTEGER,
INTENT(in) :: itrans
358 INTEGER,
TARGET,
INTENT(in) :: f(:,:)
359 INTEGER,
TARGET,
INTENT(out) :: g(:,:)
361 INTEGER,
POINTER :: p_in, p_out
368 END SUBROUTINE exchange2d_2d
370 SUBROUTINE exchange3d_3d(itrans, f, g)
371 INTEGER,
INTENT(in) :: itrans
372 INTEGER,
TARGET,
INTENT(in) :: f(:,:,:)
373 INTEGER,
TARGET,
INTENT(out) :: g(:,:,:)
375 INTEGER,
POINTER :: p_in, p_out
382 END SUBROUTINE exchange3d_3d
385 SUBROUTINE exchange2d_3d(itrans, f, g)
386 INTEGER,
INTENT(in) :: itrans
387 INTEGER,
TARGET,
INTENT(in) :: f(:,:)
388 INTEGER,
TARGET,
INTENT(out) :: g(:,:,:)
390 INTEGER,
POINTER :: p_in, p_out
397 END SUBROUTINE exchange2d_3d
399 SUBROUTINE gen_trans(itemp, send_dt, recv_dt, itrans)
400 INTEGER,
INTENT(in) :: itemp, send_dt, recv_dt
401 INTEGER,
INTENT(out) :: itrans
405 IF (send_dt /= recv_dt) &
406 CALL ut_abort(
'gen_trans: (send_dt /= recv_dt) unsupported', &
409 CALL ut_init_transposition(itemp, dt, itrans)
411 END SUBROUTINE gen_trans
413 SUBROUTINE gen_off_trans(itemp, send_dt, send_off, recv_dt, recv_off, itrans)
414 INTEGER,
INTENT(in) :: itemp, send_dt, recv_dt
415 INTEGER,
INTENT(in) :: send_off(:,:), recv_off(:,:)
416 INTEGER,
INTENT(out) :: itrans
418 INTEGER :: send_offsets(SIZE(send_off)), recv_offsets(SIZE(recv_off))
420 send_offsets = reshape(send_off, (/
SIZE(send_off)/) )
421 recv_offsets = reshape(recv_off, (/
SIZE(recv_off)/) )
423 CALL ut_init_transposition(itemp, send_offsets, recv_offsets, &
424 send_dt, recv_dt, itrans)
426 END SUBROUTINE gen_off_trans
428 SUBROUTINE get_window(gval, win)
429 INTEGER,
INTENT(in) :: gval(:,:)
430 INTEGER,
INTENT(out) :: win(:,:)
432 INTEGER :: i, j, ig, jg
438 win(i,j) = gval(ig,jg)
442 END SUBROUTINE get_window
444 SUBROUTINE gen_template_2d(local_src_idx, local_dst_idx, ihandle)
445 INTEGER,
INTENT(in) :: local_src_idx(:,:)
446 INTEGER,
INTENT(in) :: local_dst_idx(:,:)
447 INTEGER,
INTENT(out) :: ihandle
449 INTEGER :: src(SIZE(local_src_idx)), dst(size(local_dst_idx))
451 INTEGER :: src_handle, dst_handle
453 src = reshape( local_src_idx, (/
SIZE(local_src_idx)/) )
454 dst = reshape( local_dst_idx, (/
SIZE(local_dst_idx)/) )
456 CALL ut_init_decomposition(src, g_ie * g_je, src_handle)
457 CALL ut_init_decomposition(dst, g_ie * g_je, dst_handle)
460 mpi_comm_world, ihandle)
465 END SUBROUTINE gen_template_2d
467 SUBROUTINE gen_template_3d(local_src_idx, local_dst_idx, ihandle)
468 INTEGER,
INTENT(in) :: local_src_idx(:,:,:)
469 INTEGER,
INTENT(in) :: local_dst_idx(:,:,:)
470 INTEGER,
INTENT(out) :: ihandle
472 INTEGER,
ALLOCATABLE :: src(:), dst(:)
473 INTEGER :: src_handle, dst_handle
475 ALLOCATE(src(
SIZE(local_src_idx)), dst(
SIZE(local_dst_idx)))
477 src = reshape( local_src_idx, (/
SIZE(local_src_idx)/) )
478 dst = reshape( local_dst_idx, (/
SIZE(local_dst_idx)/) )
480 CALL ut_init_decomposition(src, g_ie * g_je, src_handle)
481 CALL ut_init_decomposition(dst, g_ie * g_je, dst_handle)
484 mpi_comm_world, ihandle)
489 END SUBROUTINE gen_template_3d
492 SUBROUTINE def_exchange(g_id, g_tpex)
493 INTEGER,
INTENT(in) :: g_id(:, :)
494 INTEGER,
INTENT(out) :: g_tpex(:, :)
495 LOGICAL,
PARAMETER :: increased_north_halo = .false.
496 LOGICAL,
PARAMETER :: with_north_halo = .true.
498 INTEGER :: g_core_is, g_core_ie, g_core_js, g_core_je
499 INTEGER :: north_halo
502 g_core_is = nhalo + 1
503 g_core_ie = g_ie-nhalo
504 g_core_js = nhalo + 1
505 g_core_je = g_je-nhalo
509 g_tpex(g_core_is:g_core_ie, g_core_js:g_core_je) &
510 = g_id(g_core_is:g_core_ie, g_core_js:g_core_je)
512 IF (with_north_halo)
THEN
515 IF (increased_north_halo)
THEN
521 IF (2*north_halo > g_core_je) &
522 CALL ut_abort(
'def_exchange: grid too small (or halo too large) &
523 &for tripolar north exchange', &
526 DO i = g_core_is, g_core_ie
527 g_tpex(i,j) = g_tpex(g_core_ie + (g_core_is-i), 2*north_halo + (1-j))
534 DO i = nhalo+1, g_ie-nhalo
535 g_tpex(i,j) = g_id(i,j)
542 DO j = g_core_je+1, g_je
543 DO i = nhalo+1, g_ie-nhalo
544 g_tpex(i,j) = g_id(i,j)
551 g_tpex(g_core_is-i,j) = g_tpex(g_core_ie+(1-i),j)
554 g_tpex(g_core_ie+i,j) = g_tpex(nhalo+i,j)
558 CALL check_g_idx (g_tpex)
560 END SUBROUTINE def_exchange
562 SUBROUTINE check_g_idx(gidx)
563 INTEGER,
INTENT(in) :: gidx(:,:)
565 IF (any(gidx == undef_index))
THEN
566 CALL ut_abort(
'check_g_idx: check failed', filename, __line__)
568 END SUBROUTINE check_g_idx
571 INTEGER :: cx0(0:nprocx-1), cxn(0:nprocx-1)
572 INTEGER :: cy0(0:nprocy-1), cyn(0:nprocy-1)
576 CALL regular_deco(g_ie-2*nhalo, cx0, cxn)
580 CALL regular_deco(g_je-2*nhalo, cy0, cyn)
583 ie = cxn(mypx) + 2*nhalo
584 je = cyn(mypy) + 2*nhalo
590 END PROGRAM test_perf
integer, parameter, public comm_forward
subroutine, public ut_init_oneway_transposition_template(decomp_handle_in, decomp_handle_out, mpi_world, comm_tmpl_handle, check_unique)
subroutine, public ut_init(decomp_size, comm_tmpl_size, comm_size, debug_lvl, mode, debug_unit)
subroutine, public ut_abort(msg, source, line)
subroutine, public ut_destroy_decomposition(handle)
subroutine, public ut_destroy_transposition_template(handle)
integer, parameter, public ut_mode_dt_p2p
subroutine, public ut_destroy_transposition(handle)