Yet Another eXchange Tool  0.9.0
test_ut.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_ut
49  USE mpi
50  USE xt_ut, ONLY: ut_abort, ut_init, ut_init_decomposition, &
53  ut_init_transposition, &
54  comm_forward, ut_transpose, ut_destroy_decomposition, &
56  USE ftest_common, ONLY: finish_mpi, icmp, id_map, factorize, regular_deco
57  IMPLICIT NONE
58 
59  ! global extents including halos
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 ! 1dim. halo border size
66  CHARACTER(len=*), PARAMETER :: filename = 'test_ut.f90'
67 
68  INTEGER :: ie, je ! local extents, including halos
69  INTEGER :: p_ioff, p_joff ! offsets within global domain
70  INTEGER :: nprocx, nprocy ! process space extents
71  INTEGER :: nprocs ! == nprocx*nprocy
72  ! process rank, process coords within (0:, 0:) process space
73  INTEGER :: mype, mypx, mypy
74  LOGICAL :: lroot ! true only for proc 0
75 
76  INTEGER(xt_int_kind) :: g_id(g_ie, g_je) ! global id
77 
78  ! global "tripolar-like" toy bounds exchange
79  INTEGER(xt_int_kind) :: g_tpex(g_ie, g_je)
80  INTEGER :: template_tpex, trans_tpex
81 
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
87 
88  ! mpi & decomposition & allocate mem:
89  CALL init_all
90 
91  ! full global index space:
92  CALL id_map(g_id)
93 
94  ! local window of global index space:
95  CALL get_window(g_id, loc_id)
96 
97  ! define bounds exchange for full global index space
98  CALL def_exchange(g_id, g_tpex)
99 
100  ! local window of global bounds exchange:
101  CALL get_window(g_tpex, loc_tpex)
102 
103  ! template: loc_id -> loc_tpex
104  CALL gen_template(loc_id, loc_tpex, template_tpex)
105 
106  ! transposition: loc_id:data -> loc_tpex:data
107  CALL gen_trans(template_tpex, mpi_integer, mpi_integer, trans_tpex)
108 
109  ! test 2d-to-2d transposition:
110  fval = int(loc_id)
111  CALL exchange2d_2d(trans_tpex, fval, gval)
112  CALL icmp('2d to 2d check', gval, int(loc_tpex), mype)
113 
114  ! define positions of surface elements within (i,k,j) array
115  CALL gen_id_pos(id_pos)
116  CALL gen_id_pos(pos3d_surf)
117  CALL gen_pos3d_surf(pos3d_surf)
118 
119  ! generate surface transposition:
120  CALL gen_off_trans(template_tpex, mpi_integer, id_pos(:,:)-1, &
121  mpi_integer, pos3d_surf(:,:)-1, surf_trans_tpex)
122 
123  ! 2d to surface boundsexchange:
124  gval3d = -1
125  CALL exchange2d_3d(surf_trans_tpex, fval, gval3d)
126  CALL icmp('surface check', gval3d(:,1,:), int(loc_tpex), mype)
127 
128  ! check sub surface:
129  CALL icmp('sub surface check', gval3d(:,2,:), int(loc_tpex)*0-1, mype)
130 
131  ! cleanup:
132  CALL ut_destroy_transposition_template(template_tpex)
133  CALL ut_destroy_transposition(trans_tpex)
134  CALL ut_destroy_transposition(surf_trans_tpex)
135 
136  DEALLOCATE(fval, gval, loc_id, loc_tpex, id_pos, gval3d, pos3d_surf)
137  CALL ut_finalize()
138  CALL finish_mpi
139 
140 CONTAINS
141 
142  SUBROUTINE gen_pos3d_surf(pos)
143  INTEGER, INTENT(inout) :: pos(:,:)
144  ! positions for zero based arrays (ECHAM grid point dim order)
145  ! old pos = i + j*ie
146  ! new pos = i + k*ie + j*ie*nlev
147  INTEGER :: ii,jj, i,j,k, p,q
148 
149  k = 0 ! surface
150  DO jj=1,je
151  DO ii=1,ie
152  p = pos(ii,jj) - 1 ! shift to 0-based index
153  j = p/ie
154  i = mod(p,ie)
155  q = i + k*ie + j*ie*nlev
156  pos(ii,jj) = q + 1 ! shift to 1-based index
157  ENDDO
158  ENDDO
159 
160  END SUBROUTINE gen_pos3d_surf
161 
162  SUBROUTINE init_all
163  CHARACTER(len=*), PARAMETER :: context = 'init_all: '
164  INTEGER :: ierror
165 
166  CALL mpi_init(ierror)
167  IF (ierror /= mpi_success) CALL ut_abort(context//'MPI_INIT failed', &
168  filename, __line__)
169 
170  CALL mpi_comm_size(mpi_comm_world, nprocs, ierror)
171  IF (ierror /= mpi_success) CALL ut_abort(context//'MPI_COMM_SIZE failed', &
172  filename, __line__)
173 
174  CALL mpi_comm_rank(mpi_comm_world, mype, ierror)
175  IF (ierror /= mpi_success) CALL ut_abort(context//'MPI_COMM_RANK failed', &
176  filename, __line__)
177  IF (mype==0) THEN
178  lroot = .true.
179  ELSE
180  lroot = .false.
181  ENDIF
182 
183  CALL factorize(nprocs, nprocx, nprocy)
184  IF (verbose .AND. lroot) WRITE(0,*) 'nprocx, nprocy=',nprocx, nprocy
185  mypy = mype / nprocx
186  mypx = mod(mype, nprocx)
187 
188  CALL ut_init(decomp_size=30, comm_tmpl_size=30, comm_size=30, &
189  & debug_lvl=0, mode=ut_mode_dt_p2p, debug_unit=0)
190 
191  CALL deco
192 
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))
196 
197  fval = undef_int
198  gval = undef_int
199  loc_id = int(undef_int, xt_int_kind)
200  loc_tpex = int(undef_int, xt_int_kind)
201  id_pos = undef_int
202  gval3d = undef_int
203  pos3d_surf = undef_int
204 
205  END SUBROUTINE init_all
206 
207  SUBROUTINE gen_id_pos(pos)
208  INTEGER, INTENT(out) :: pos(:,:)
209 
210  INTEGER :: i,j
211  INTEGER :: p
212 
213  p = 0
214  DO j = 1, SIZE(pos,2)
215  DO i = 1, SIZE(pos,1)
216  p = p + 1
217  pos(i,j) = p
218  ENDDO
219  ENDDO
220 
221  END SUBROUTINE gen_id_pos
222 
223 
224  SUBROUTINE exchange2d_2d(itrans, f, g)
225  INTEGER, INTENT(in) :: itrans
226  INTEGER, TARGET, INTENT(in) :: f(:,:)
227  INTEGER, TARGET, INTENT(out) :: g(:,:)
228 
229  INTEGER, POINTER :: p_in, p_out
230 
231  p_in => f(1,1)
232  p_out=> g(1,1)
233 
234  CALL ut_transpose(p_in, itrans, comm_forward, p_out)
235 
236  END SUBROUTINE exchange2d_2d
237 
238  SUBROUTINE exchange2d_3d(itrans, f, g)
239  INTEGER, INTENT(in) :: itrans
240  INTEGER, TARGET, INTENT(in) :: f(:,:)
241  INTEGER, TARGET, INTENT(out) :: g(:,:,:)
242 
243  INTEGER, POINTER :: p_in, p_out
244 
245  p_in => f(1,1)
246  p_out=> g(1,1,1)
247 
248  CALL ut_transpose(p_in, itrans, comm_forward, p_out)
249 
250  END SUBROUTINE exchange2d_3d
251 
252  SUBROUTINE gen_trans(itemp, send_dt, recv_dt, itrans)
253  INTEGER,INTENT(in) :: itemp, send_dt, recv_dt
254  INTEGER,INTENT(out) :: itrans
255 
256  INTEGER :: dt
257 
258  IF (send_dt /= recv_dt) &
259  CALL ut_abort('gen_trans: (send_dt /= recv_dt) unsupported', &
260  filename, __line__)
261  dt = send_dt
262  CALL ut_init_transposition(itemp, dt, itrans)
263 
264  END SUBROUTINE gen_trans
265 
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
270 
271  INTEGER :: send_offsets(SIZE(send_off)), recv_offsets(SIZE(recv_off))
272 
273  send_offsets = reshape(send_off, (/SIZE(send_off)/) )
274  recv_offsets = reshape(recv_off, (/SIZE(recv_off)/) )
275 
276  CALL ut_init_transposition(itemp, send_offsets, recv_offsets, &
277  send_dt, recv_dt, itrans)
278 
279  END SUBROUTINE gen_off_trans
280 
281  SUBROUTINE get_window(gval, win)
282  INTEGER(xt_int_kind), INTENT(in) :: gval(:,:)
283  INTEGER(xt_int_kind), INTENT(out) :: win(:,:)
284 
285  INTEGER :: i, j, ig, jg
286 
287  DO j = 1, je
288  jg = p_joff + j
289  DO i = 1, ie
290  ig = p_ioff + i
291  win(i,j) = gval(ig,jg)
292  ENDDO
293  ENDDO
294 
295  END SUBROUTINE get_window
296 
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
301 
302  INTEGER :: tmp(MAX(SIZE(local_src_idx), SIZE(local_dst_idx)))
303 
304  INTEGER :: src_handle, dst_handle, i, j, m, n
305 
306  m = SIZE(local_src_idx, 1)
307  n = SIZE(local_src_idx, 2)
308  DO j = 1, n
309  DO i = 1, m
310  tmp((j-1)*m+i) = int(local_src_idx(i,j))
311  END DO
312  END DO
313  CALL ut_init_decomposition(tmp, g_ie * g_je, src_handle)
314 
315  m = SIZE(local_dst_idx, 1)
316  n = SIZE(local_dst_idx, 2)
317  DO j = 1, n
318  DO i = 1, m
319  tmp((j-1)*m+i) = int(local_dst_idx(i,j))
320  END DO
321  END DO
322  CALL ut_init_decomposition(tmp, g_ie * g_je, dst_handle)
323 
324  CALL ut_init_oneway_transposition_template(src_handle, dst_handle, &
325  mpi_comm_world, ihandle)
326 
327  CALL ut_destroy_decomposition(dst_handle)
328  CALL ut_destroy_decomposition(src_handle)
329 
330  END SUBROUTINE gen_template
331 
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(:,:)
335 
336  LOGICAL, PARAMETER :: increased_north_halo = .false.
337  LOGICAL, PARAMETER :: with_north_halo = .true.
338  INTEGER :: i, j
339  INTEGER :: g_core_is, g_core_ie, g_core_js, g_core_je
340  INTEGER :: north_halo
341 
342  ! global core domain:
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
347 
348  ! global tripolar boundsexchange:
349  id_out = undef_index
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)
352 
353  IF (with_north_halo) THEN
354 
355  ! north inversion, (maybe with increased north halo)
356  IF (increased_north_halo) THEN
357  north_halo = nhalo+1
358  ELSE
359  north_halo = nhalo
360  ENDIF
361 
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', &
365  filename, __line__)
366  DO j = 1, north_halo
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))
369  ENDDO
370  ENDDO
371 
372  ELSE
373 
374  DO j = 1, nhalo
375  DO i = nhalo+1, g_ie-nhalo
376  id_out(i,j) = id_in(i,j)
377  ENDDO
378  ENDDO
379 
380  ENDIF
381 
382  ! south: no change
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)
386  ENDDO
387  ENDDO
388 
389  ! PBC
390  DO j = 1, g_je
391  DO i = 1, nhalo
392  id_out(g_core_is-i,j) = id_out(g_core_ie+(1-i),j)
393  ENDDO
394  DO i = 1, nhalo
395  id_out(g_core_ie+i,j) = id_out(nhalo+i,j)
396  ENDDO
397  ENDDO
398 
399  CALL check_g_idx(id_out)
400 
401  END SUBROUTINE def_exchange
402 
403  SUBROUTINE check_g_idx(gidx)
404  INTEGER(xt_int_kind), INTENT(in) :: gidx(:,:)
405 
406  IF (any(gidx == undef_index)) THEN
407  CALL ut_abort('check_g_idx: check failed', filename, __line__)
408  ENDIF
409  END SUBROUTINE check_g_idx
410 
411  SUBROUTINE deco
412  INTEGER :: cx0(0:nprocx-1), cxn(0:nprocx-1)
413  INTEGER :: cy0(0:nprocy-1), cyn(0:nprocy-1)
414 
415  CALL regular_deco(g_ie-2*nhalo, cx0, cxn)
416  CALL regular_deco(g_je-2*nhalo, cy0, cyn)
417 
418  ! process local deco variables:
419  ie = cxn(mypx) + 2*nhalo
420  je = cyn(mypy) + 2*nhalo
421  p_ioff = cx0(mypx)
422  p_joff = cy0(mypy)
423 
424  END SUBROUTINE deco
425 
426 END PROGRAM test_ut
427 !
428 ! Local Variables:
429 ! f90-continuation-indent: 5
430 ! coding: utf-8
431 ! indent-tabs-mode: nil
432 ! show-trailing-whitespace: t
433 ! require-trailing-newline: t
434 ! End:
435 !
Definition: xt_ut.f90:50
integer, parameter, public comm_forward
Definition: xt_ut.f90:76
subroutine, public ut_init_oneway_transposition_template(decomp_handle_in, decomp_handle_out, mpi_world, comm_tmpl_handle, check_unique)
Definition: xt_ut.f90:275
subroutine, public ut_finalize()
Definition: xt_ut.f90:226
subroutine, public ut_init(decomp_size, comm_tmpl_size, comm_size, debug_lvl, mode, debug_unit)
Definition: xt_ut.f90:231
subroutine, public ut_abort(msg, source, line)
Definition: xt_ut.f90:217
subroutine, public ut_destroy_decomposition(handle)
Definition: xt_ut.f90:267
subroutine, public ut_destroy_transposition_template(handle)
Definition: xt_ut.f90:293
integer, parameter, public ut_mode_dt_p2p
Definition: xt_ut.f90:79
subroutine, public ut_destroy_transposition(handle)
Definition: xt_ut.f90:337