53 ut_init_transposition, &
56 USE ftest_common,
ONLY: finish_mpi, icmp, id_map, factorize, regular_deco
60 INTEGER,
PARAMETER :: g_ie = 8, g_je = 4
61 LOGICAL,
PARAMETER :: verbose = .false.
62 INTEGER,
PARAMETER :: nlev = 3
63 INTEGER,
PARAMETER :: undef_int = g_ie * g_je * nlev + 1
64 INTEGER(xt_int_kind),
PARAMETER :: undef_index = -1
65 INTEGER,
PARAMETER :: nhalo = 1
66 CHARACTER(len=*),
PARAMETER :: filename =
'test_ut.f90'
69 INTEGER :: p_ioff, p_joff
70 INTEGER :: nprocx, nprocy
73 INTEGER :: mype, mypx, mypy
76 INTEGER(xt_int_kind) :: g_id(g_ie, g_je)
79 INTEGER(xt_int_kind) :: g_tpex(g_ie, g_je)
80 INTEGER :: template_tpex, trans_tpex
82 INTEGER(xt_int_kind),
ALLOCATABLE :: loc_id(:,:), loc_tpex(:,:)
83 INTEGER,
ALLOCATABLE :: fval(:,:), gval(:,:)
84 INTEGER,
ALLOCATABLE :: gval3d(:,:,:)
85 INTEGER,
ALLOCATABLE :: id_pos(:,:), pos3d_surf(:,:)
86 INTEGER :: surf_trans_tpex
95 CALL get_window(g_id, loc_id)
98 CALL def_exchange(g_id, g_tpex)
101 CALL get_window(g_tpex, loc_tpex)
104 CALL gen_template(loc_id, loc_tpex, template_tpex)
107 CALL gen_trans(template_tpex, mpi_integer, mpi_integer, trans_tpex)
111 CALL exchange2d_2d(trans_tpex, fval, gval)
112 CALL icmp(
'2d to 2d check', gval, int(loc_tpex), mype)
115 CALL gen_id_pos(id_pos)
116 CALL gen_id_pos(pos3d_surf)
117 CALL gen_pos3d_surf(pos3d_surf)
120 CALL gen_off_trans(template_tpex, mpi_integer, id_pos(:,:)-1, &
121 mpi_integer, pos3d_surf(:,:)-1, surf_trans_tpex)
125 CALL exchange2d_3d(surf_trans_tpex, fval, gval3d)
126 CALL icmp(
'surface check', gval3d(:,1,:), int(loc_tpex), mype)
129 CALL icmp(
'sub surface check', gval3d(:,2,:), int(loc_tpex)*0-1, mype)
136 DEALLOCATE(fval, gval, loc_id, loc_tpex, id_pos, gval3d, pos3d_surf)
142 SUBROUTINE gen_pos3d_surf(pos)
143 INTEGER,
INTENT(inout) :: pos(:,:)
147 INTEGER :: ii,jj, i,j,k, p,q
155 q = i + k*ie + j*ie*nlev
160 END SUBROUTINE gen_pos3d_surf
163 CHARACTER(len=*),
PARAMETER :: context =
'init_all: '
166 CALL mpi_init(ierror)
167 IF (ierror /= mpi_success)
CALL ut_abort(context//
'MPI_INIT failed', &
170 CALL mpi_comm_size(mpi_comm_world, nprocs, ierror)
171 IF (ierror /= mpi_success)
CALL ut_abort(context//
'MPI_COMM_SIZE failed', &
174 CALL mpi_comm_rank(mpi_comm_world, mype, ierror)
175 IF (ierror /= mpi_success)
CALL ut_abort(context//
'MPI_COMM_RANK failed', &
183 CALL factorize(nprocs, nprocx, nprocy)
184 IF (verbose .AND. lroot)
WRITE(0,*)
'nprocx, nprocy=',nprocx, nprocy
186 mypx = mod(mype, nprocx)
188 CALL ut_init(decomp_size=30, comm_tmpl_size=30, comm_size=30, &
193 ALLOCATE(fval(ie,je), gval(ie,je))
194 ALLOCATE(loc_id(ie,je), loc_tpex(ie,je))
195 ALLOCATE(id_pos(ie,je), gval3d(ie,nlev,je), pos3d_surf(ie,je))
199 loc_id = int(undef_int, xt_int_kind)
200 loc_tpex = int(undef_int, xt_int_kind)
203 pos3d_surf = undef_int
205 END SUBROUTINE init_all
207 SUBROUTINE gen_id_pos(pos)
208 INTEGER,
INTENT(out) :: pos(:,:)
214 DO j = 1,
SIZE(pos,2)
215 DO i = 1,
SIZE(pos,1)
221 END SUBROUTINE gen_id_pos
224 SUBROUTINE exchange2d_2d(itrans, f, g)
225 INTEGER,
INTENT(in) :: itrans
226 INTEGER,
TARGET,
INTENT(in) :: f(:,:)
227 INTEGER,
TARGET,
INTENT(out) :: g(:,:)
229 INTEGER,
POINTER :: p_in, p_out
236 END SUBROUTINE exchange2d_2d
238 SUBROUTINE exchange2d_3d(itrans, f, g)
239 INTEGER,
INTENT(in) :: itrans
240 INTEGER,
TARGET,
INTENT(in) :: f(:,:)
241 INTEGER,
TARGET,
INTENT(out) :: g(:,:,:)
243 INTEGER,
POINTER :: p_in, p_out
250 END SUBROUTINE exchange2d_3d
252 SUBROUTINE gen_trans(itemp, send_dt, recv_dt, itrans)
253 INTEGER,
INTENT(in) :: itemp, send_dt, recv_dt
254 INTEGER,
INTENT(out) :: itrans
258 IF (send_dt /= recv_dt) &
259 CALL ut_abort(
'gen_trans: (send_dt /= recv_dt) unsupported', &
262 CALL ut_init_transposition(itemp, dt, itrans)
264 END SUBROUTINE gen_trans
266 SUBROUTINE gen_off_trans(itemp, send_dt, send_off, recv_dt, recv_off, itrans)
267 INTEGER,
INTENT(in) :: itemp, send_dt, recv_dt
268 INTEGER,
INTENT(in) :: send_off(:,:), recv_off(:,:)
269 INTEGER,
INTENT(out) :: itrans
271 INTEGER :: send_offsets(SIZE(send_off)), recv_offsets(SIZE(recv_off))
273 send_offsets = reshape(send_off, (/
SIZE(send_off)/) )
274 recv_offsets = reshape(recv_off, (/
SIZE(recv_off)/) )
276 CALL ut_init_transposition(itemp, send_offsets, recv_offsets, &
277 send_dt, recv_dt, itrans)
279 END SUBROUTINE gen_off_trans
281 SUBROUTINE get_window(gval, win)
282 INTEGER(xt_int_kind),
INTENT(in) :: gval(:,:)
283 INTEGER(xt_int_kind),
INTENT(out) :: win(:,:)
285 INTEGER :: i, j, ig, jg
291 win(i,j) = gval(ig,jg)
295 END SUBROUTINE get_window
297 SUBROUTINE gen_template(local_src_idx, local_dst_idx, ihandle)
298 INTEGER(xt_int_kind),
INTENT(in) :: local_src_idx(:,:)
299 INTEGER(xt_int_kind),
INTENT(in) :: local_dst_idx(:,:)
300 INTEGER,
INTENT(out) :: ihandle
302 INTEGER :: tmp(MAX(SIZE(local_src_idx), SIZE(local_dst_idx)))
304 INTEGER :: src_handle, dst_handle, i, j, m, n
306 m =
SIZE(local_src_idx, 1)
307 n =
SIZE(local_src_idx, 2)
310 tmp((j-1)*m+i) = int(local_src_idx(i,j))
313 CALL ut_init_decomposition(tmp, g_ie * g_je, src_handle)
315 m =
SIZE(local_dst_idx, 1)
316 n =
SIZE(local_dst_idx, 2)
319 tmp((j-1)*m+i) = int(local_dst_idx(i,j))
322 CALL ut_init_decomposition(tmp, g_ie * g_je, dst_handle)
325 mpi_comm_world, ihandle)
330 END SUBROUTINE gen_template
332 SUBROUTINE def_exchange(id_in, id_out)
333 INTEGER(xt_int_kind),
INTENT(in) :: id_in(:,:)
334 INTEGER(xt_int_kind),
INTENT(out) :: id_out(:,:)
336 LOGICAL,
PARAMETER :: increased_north_halo = .false.
337 LOGICAL,
PARAMETER :: with_north_halo = .true.
339 INTEGER :: g_core_is, g_core_ie, g_core_js, g_core_je
340 INTEGER :: north_halo
343 g_core_is = nhalo + 1
344 g_core_ie = g_ie-nhalo
345 g_core_js = nhalo + 1
346 g_core_je = g_je-nhalo
350 id_out(g_core_is:g_core_ie, g_core_js:g_core_je) &
351 = id_in(g_core_is:g_core_ie, g_core_js:g_core_je)
353 IF (with_north_halo)
THEN
356 IF (increased_north_halo)
THEN
362 IF (2*north_halo > g_core_je) &
363 CALL ut_abort(
'def_exchange: grid too small (or halo too large)&
364 & for tripolar north exchange', &
367 DO i = g_core_is, g_core_ie
368 id_out(i,j) = id_out(g_core_ie + (g_core_is-i), 2*north_halo + (1-j))
375 DO i = nhalo+1, g_ie-nhalo
376 id_out(i,j) = id_in(i,j)
383 DO j = g_core_je+1, g_je
384 DO i = nhalo+1, g_ie-nhalo
385 id_out(i,j) = id_in(i,j)
392 id_out(g_core_is-i,j) = id_out(g_core_ie+(1-i),j)
395 id_out(g_core_ie+i,j) = id_out(nhalo+i,j)
399 CALL check_g_idx(id_out)
401 END SUBROUTINE def_exchange
403 SUBROUTINE check_g_idx(gidx)
404 INTEGER(xt_int_kind),
INTENT(in) :: gidx(:,:)
406 IF (any(gidx == undef_index))
THEN
407 CALL ut_abort(
'check_g_idx: check failed', filename, __line__)
409 END SUBROUTINE check_g_idx
412 INTEGER :: cx0(0:nprocx-1), cxn(0:nprocx-1)
413 INTEGER :: cy0(0:nprocy-1), cyn(0:nprocy-1)
415 CALL regular_deco(g_ie-2*nhalo, cx0, cxn)
416 CALL regular_deco(g_je-2*nhalo, cy0, cyn)
419 ie = cxn(mypx) + 2*nhalo
420 je = cyn(mypy) + 2*nhalo
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_finalize()
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)