Yet Another eXchange Tool  0.9.0
test_yaxt.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_yaxt
49  USE iso_c_binding, ONLY: c_int
50  USE mpi
51  USE yaxt, ONLY: xt_idxlist, xt_idxlist_delete, xt_idxvec_new, &
52  & xt_xmap, xt_xmap_all2all_new, xt_xmap_delete, &
53  & xt_redist, xt_redist_p2p_new, xt_redist_delete, &
57  xt_idxfsection_new, xt_redist_collection_static_new
58  USE ftest_common, ONLY: test_abort, id_map, factorize, regular_deco, &
59  finish_mpi, cmp_arrays
60 
61  ! PGI compilers up to at least version 15 do not handle generic
62  ! interfaces correctly
63 #if defined __PGI
67 #endif
68  IMPLICIT NONE
69 
70  INTEGER, PARAMETER :: g_ie = 8, g_je = 4! global extents including halos
71  LOGICAL, PARAMETER :: verbose = .false.
72  INTEGER, PARAMETER :: nlev = 3
73  INTEGER, PARAMETER :: undef_int = -1
74  INTEGER(xt_int_kind), PARAMETER :: undef_index = -1
75  INTEGER, PARAMETER :: nhalo = 1 ! 1dim. halo border size
76  LOGICAL, PARAMETER :: increased_north_halo = .false.
77  LOGICAL, PARAMETER :: with_north_halo = .true.
78 
79  INTEGER :: ie, je ! local extents, including halos
80  INTEGER :: p_ioff, p_joff ! offsets within global domain
81  INTEGER :: nprocx, nprocy ! process space extents
82  INTEGER :: nprocs ! == nprocx*nprocy
83  INTEGER :: mype, mypx, mypy ! process rank, process coords within (0:, 0:) process space
84  LOGICAL :: lroot ! true only for proc 0
85 
86  INTEGER(xt_int_kind) :: g_id(g_ie, g_je) ! global id
87  CHARACTER(len=*), PARAMETER :: filename = 'test_yaxt.f90'
88  ! global "tripolar-like" toy bounds exchange
89  INTEGER(xt_int_kind) :: g_tpex(g_ie, g_je)
90  TYPE(xt_xmap) :: xmap_tpex
91  TYPE(xt_redist) :: redist_tpex
92  TYPE(xt_redist) :: redist_surf_tpex
93 
94  INTEGER(xt_int_kind), ALLOCATABLE :: loc_id(:,:), loc_tpex(:,:)
95  INTEGER, ALLOCATABLE :: fval(:,:), gval(:,:)
96  INTEGER, ALLOCATABLE :: gval3d(:,:,:)
97  INTEGER, ALLOCATABLE :: id_pos(:,:), pos3d_surf(:,:)
98 
99  ! mpi & decomposition & allocate mem:
100  CALL init_all
101 
102  ! full global index space:
103  CALL id_map(g_id)
104 
105  ! local window of global index space:
106  CALL get_window(g_id, loc_id)
107 
108  ! define bounds exchange for full global index space
109  CALL def_exchange(g_id, g_tpex)
110 
111  ! local window of global bounds exchange:
112  CALL get_window(g_tpex, loc_tpex)
113 
114  ! check interface to idxsection:
115  CALL general_fsection_test
116 
117  ! compare current index construction with modifier results
118  CALL check_modifiers
119 
120  ! template: loc_id -> loc_tpex
121  CALL gen_template(loc_id, loc_tpex, xmap_tpex) ! todo rename template to xmap
122 
123  ! transposition: loc_id:data -> loc_tpex:data
124  CALL gen_trans(xmap_tpex, mpi_integer, mpi_integer, redist_tpex)
125 
126  ! test 2d-to-2d transposition:
127  fval = int(loc_id)
128  CALL xt_redist_s_exchange(redist_tpex, fval, gval)
129 
130  IF (cmp_arrays(gval, loc_tpex)) &
131  CALL test_abort('array eqivalence test failed', filename, __line__)
132  DEALLOCATE(gval)
133  CALL check_redist_collection_static
134  DEALLOCATE(loc_id)
135 
136  ! define positions of surface elements within (i,k,j) array
137  CALL gen_id_pos(id_pos)
138  CALL gen_id_pos(pos3d_surf)
139  CALL gen_pos3d_surf(pos3d_surf)
140 
141  ! generate surface transposition:
142  CALL gen_off_trans(xmap_tpex, mpi_integer, id_pos(:,:) - 1, &
143  mpi_integer, pos3d_surf, redist_surf_tpex)
144  DEALLOCATE(pos3d_surf, id_pos)
145 
146  ! 2d to surface boundsexchange:
147  gval3d = -1
148  CALL xt_redist_s_exchange(redist_surf_tpex, &
149  reshape(fval, (/ ie, 1, je /)), gval3d)
150  DEALLOCATE(fval)
151 
152  IF (cmp_arrays(gval3d(:, 1, :), loc_tpex)) &
153  CALL test_abort('surface check failed', filename, __line__)
154  ! check sub surface:
155  IF (any(gval3d(:, 2, :) /= -1)) &
156  CALL test_abort('surface check failed', filename, __line__)
157 
158  ! cleanup:
159  DEALLOCATE(loc_tpex, gval3d)
160  CALL xt_xmap_delete(xmap_tpex)
161 
162  CALL xt_redist_delete(redist_tpex)
163 
164  CALL xt_redist_delete(redist_surf_tpex)
165 
166  CALL xt_finalize()
167  CALL finish_mpi
168 
169 CONTAINS
170 
171 #define abort(msg, line) test_abort(msg, filename, line)
172 
173  SUBROUTINE check_redist_collection_static
174  INTEGER, PARAMETER :: nr = 2
175  TYPE(xt_redist) :: rvec(nr), rcol
176  INTEGER :: f(ie,je,nr), g(ie,je,nr), ref_g(ie,je,nr)
177  INTEGER(mpi_address_kind) :: f_addr(nr), g_addr(nr)
178  INTEGER(mpi_address_kind) :: f_disp(nr), g_disp(nr)
179 
180  INTEGER :: ir, ierror
181  rvec(:) = redist_tpex
182  DO ir = 1, nr
183  CALL mpi_get_address(f(1,1,ir), f_addr(ir), ierror)
184  IF (ierror /= mpi_success) &
185  CALL abort('MPI_GET_ADDRESS failed', __line__)
186  CALL mpi_get_address(g(1,1,ir), g_addr(ir), ierror)
187  IF (ierror /= mpi_success) &
188  CALL abort('MPI_GET_ADDRESS failed', __line__)
189  f_disp(ir) = f_addr(ir) - f_addr(1)
190  g_disp(ir) = g_addr(ir) - g_addr(1)
191  ENDDO
192 
193  rcol = xt_redist_collection_static_new(rvec, nr, f_disp, g_disp, mpi_comm_world)
194  DO ir = 1, nr
195  f(:,:,ir) = int(loc_id) + (ir-1) * ie*je
196  ENDDO
197 
198  ref_g = 0
199  DO ir = 1, nr
200  CALL xt_redist_s_exchange(rvec(ir), f(:,:,ir), ref_g(:,:,ir))
201  ENDDO
202 
203  g = 0
204  CALL xt_redist_s_exchange(rcol, f, g)
205  IF (any(g /= ref_g)) CALL abort('(g /= ref_g)', __line__)
206  CALL xt_redist_delete(rcol)
207 
208  END SUBROUTINE check_redist_collection_static
209 
210  SUBROUTINE check_modifiers()
211  TYPE(xt_modifier) :: m_tpex(5)
212  INTEGER :: m_tpex_num
213  TYPE(xt_idxlist) :: loc_id_idxlist
214  INTEGER(xt_int_kind) :: loc_tpex2(ie,je)
215  TYPE(xt_idxlist) :: loc_tpex2_idxlist
216  INTEGER(c_int), ALLOCATABLE :: mstate(:,:)
217 
218  loc_id_idxlist = xt_idxvec_new(loc_id, SIZE(loc_id))
219  ALLOCATE(mstate(ie,je))
220 
221  ! use one simple modifier to define index transfer:
222  CALL def_tpex_mod_via_idxvec(m_tpex, m_tpex_num)
223 
224  loc_tpex2_idxlist = xt_idxmod_new(loc_id_idxlist, m_tpex, m_tpex_num, mstate)
225  loc_tpex2 = -1
226  CALL xt_idxlist_get_indices(loc_tpex2_idxlist, loc_tpex2)
227  IF (any(loc_tpex2 /= loc_tpex)) &
228  CALL abort('idx copy does not match', __line__)
229  CALL xt_idxlist_delete(loc_tpex2_idxlist)
230 
231  ! test call without mstate
232  loc_tpex2_idxlist = xt_idxmod_new(loc_id_idxlist, m_tpex, m_tpex_num)
233  loc_tpex2 = -1
234  CALL xt_idxlist_get_indices(loc_tpex2_idxlist, loc_tpex2)
235  IF (any(loc_tpex2 /= loc_tpex)) &
236  CALL abort('idx copy does not match', __line__)
237  CALL xt_idxlist_delete(loc_tpex2_idxlist)
238  CALL delete_modifiers(m_tpex(1:m_tpex_num))
239 
240  ! use compact modifiers to define index transfer:
241  CALL def_tpex_mod_via_sections(m_tpex, m_tpex_num)
242  loc_tpex2_idxlist = xt_idxmod_new(loc_id_idxlist, m_tpex, m_tpex_num, mstate)
243  loc_tpex2 = -1
244  CALL xt_idxlist_get_indices(loc_tpex2_idxlist, loc_tpex2)
245 
246  IF (any(loc_tpex2 /= loc_tpex)) &
247  CALL abort('idx copy does not match', __line__)
248  CALL xt_idxlist_delete(loc_tpex2_idxlist)
249  CALL delete_modifiers(m_tpex(1:m_tpex_num))
250 
251  ! cleanup:
252  CALL xt_idxlist_delete(loc_id_idxlist)
253  END SUBROUTINE check_modifiers
254 
255  SUBROUTINE delete_modifiers(m)
256  TYPE(xt_modifier), INTENT(inout) :: m(:)
257 
258  INTEGER :: i
259 
260  DO i = 1, SIZE(m)
261  CALL xt_idxlist_delete(m(i)%extract)
262  CALL xt_idxlist_delete(m(i)%subst)
263  ENDDO
264 
265  END SUBROUTINE delete_modifiers
266 
267  SUBROUTINE general_fsection_test
268  INTEGER(xt_int_kind), PARAMETER :: gdx = 10_xt_int_kind, gdy=5_xt_int_kind
269  INTEGER, PARAMETER :: ldx = 4, ldy=2
270  INTEGER(xt_int_kind), PARAMETER :: gstart = 1
271  INTEGER(xt_int_kind), PARAMETER :: gsize(2) = (/ gdx, gdy /)
272  TYPE(xt_idxlist) :: global_section, local_section
273  INTEGER(xt_int_kind) :: indices(gdx*gdy), lstart(2)
274  INTEGER :: egis(gdx, gdy)
275  INTEGER :: i, j, idx, p
276 
277  ! prepare explicit global index space
278  idx = gstart - 1
279  DO j = 1, gdy
280  DO i = 1, gdx
281  idx = idx + 1
282  egis(i,j) = idx
283  ENDDO
284  ENDDO
285 
286  lstart = (/ 1_xt_int_kind, 1_xt_int_kind /)
287 
288  ! check case: local section == global section
289  global_section = xt_idxfsection_new(gstart, gsize, int(gsize), lstart)
290  indices = -1
291  CALL xt_idxlist_get_indices(global_section, indices)
292  p = 0
293  DO j = 1, gdy
294  DO i = 1, gdx
295  p = p + 1
296  IF (egis(i,j) /= indices(p)) CALL abort('(1) bad indices', __line__)
297  ENDDO
298  ENDDO
299  CALL xt_idxlist_delete(global_section)
300 
301  ! check case: simple subsection
302  local_section = xt_idxfsection_new(gstart, gsize, (/ ldx, ldy /), lstart)
303  indices = -1
304  CALL xt_idxlist_get_indices(local_section, indices)
305  p = 0
306  DO j = 1, ldy
307  DO i = 1, ldx
308  p = p + 1
309  IF (egis(i,j) /= indices(p)) CALL abort('(2) bad indices', __line__)
310  ENDDO
311  ENDDO
312  CALL xt_idxlist_delete(local_section)
313 
314  ! check case: i-reverse subsection
315  local_section = xt_idxfsection_new(gstart, gsize, &
316  (/ -ldx, ldy /), lstart)
317  indices = -1
318  CALL xt_idxlist_get_indices(local_section, indices)
319  p = 0
320  DO j = 1, ldy
321  DO i = ldx, 1, -1
322  p = p + 1
323  IF (egis(i,j) /= indices(p)) CALL abort('(3) bad indices', __line__)
324  ENDDO
325  ENDDO
326  CALL xt_idxlist_delete(local_section)
327 
328  ! check case: j-reverse subsection
329  local_section = xt_idxfsection_new(gstart, gsize, (/ ldx, -ldy /), lstart)
330  indices = -1
331  CALL xt_idxlist_get_indices(local_section, indices)
332  p = 0
333  DO j = ldy, 1, -1
334  DO i = 1, ldx
335  p = p + 1
336  IF (egis(i,j) /= indices(p)) CALL abort('(4) bad indices', __line__)
337  ENDDO
338  ENDDO
339  CALL xt_idxlist_delete(local_section)
340 
341  ! check case: ij-reverse subsection
342  local_section = xt_idxfsection_new(gstart, gsize, &
343  (/ -ldx, -ldy /), lstart)
344  indices = -1
345  CALL xt_idxlist_get_indices(local_section, indices)
346  p = 0
347  DO j = ldy, 1, -1
348  DO i = ldx, 1, -1
349  p = p + 1
350  IF (egis(i,j) /= indices(p)) CALL abort('(5) bad indices', __line__)
351  ENDDO
352  ENDDO
353  CALL xt_idxlist_delete(local_section)
354  END SUBROUTINE general_fsection_test
355 
356  SUBROUTINE gen_pos3d_surf(pos)
357  INTEGER, INTENT(inout) :: pos(:,:)
358  ! positions for zero based arrays (ECHAM grid point dim order)
359  ! old pos = i + j*ie
360  ! new pos = i + k*ie + j*ie*nlev
361  INTEGER :: ii,jj, i,j,k, p
362 
363  k = 0 ! surface
364  DO jj=1,je
365  DO ii=1,ie
366  p = pos(ii,jj) - 1 ! shift to 0-based index
367  j = p/ie
368  i = mod(p,ie)
369  pos(ii,jj) = i + k*ie + j*ie*nlev
370  ENDDO
371  ENDDO
372 
373  END SUBROUTINE gen_pos3d_surf
374 
375  SUBROUTINE init_all
376  CHARACTER(len=*), PARAMETER :: context = 'init_all: '
377  INTEGER :: ierror
378 
379  CALL mpi_init(ierror)
380  IF (ierror /= mpi_success) &
381  CALL abort(context//'MPI_INIT failed', __line__)
382 
383  CALL xt_initialize(mpi_comm_world)
384 
385  CALL mpi_comm_size(mpi_comm_world, nprocs, ierror)
386  IF (ierror /= mpi_success) &
387  CALL abort(context//'MPI_COMM_SIZE failed', __line__)
388 
389  CALL mpi_comm_rank(mpi_comm_world, mype, ierror)
390  IF (ierror /= mpi_success) &
391  CALL abort(context//'MPI_COMM_RANK failed', __line__)
392  IF (mype==0) THEN
393  lroot = .true.
394  ELSE
395  lroot = .false.
396  ENDIF
397 
398  CALL factorize(nprocs, nprocx, nprocy)
399  IF (verbose .AND. lroot) WRITE(0,*) 'nprocx, nprocy=',nprocx, nprocy
400  mypy = mype / nprocx
401  mypx = mod(mype, nprocx)
402 
403  !CALL ut_init(decomp_size=30, comm_tmpl_size=30, comm_size=30, &
404  ! & debug_lvl=0, mode=ut_mode_dt_p2p, debug_unit=0)
405 
406  CALL deco
407 
408  ALLOCATE(fval(ie,je), gval(ie,je))
409  ALLOCATE(loc_id(ie,je), loc_tpex(ie,je))
410  ALLOCATE(id_pos(ie,je), gval3d(ie,nlev,je), pos3d_surf(ie,je))
411 
412  fval = undef_int
413  gval = undef_int
414  loc_id = int(undef_int, xt_int_kind)
415  loc_tpex = int(undef_int, xt_int_kind)
416  id_pos = undef_int
417  gval3d = undef_int
418  pos3d_surf = undef_int
419 
420  END SUBROUTINE init_all
421 
422  SUBROUTINE gen_id_pos(pos)
423  INTEGER, INTENT(out) :: pos(:,:)
424 
425  INTEGER :: i,j,p
426 
427  p = 0
428  DO j = 1, SIZE(pos,2)
429  DO i = 1, SIZE(pos,1)
430  p = p + 1
431  pos(i,j) = p
432  ENDDO
433  ENDDO
434 
435  END SUBROUTINE gen_id_pos
436 
437  SUBROUTINE gen_trans(xmap, send_dt, recv_dt, redist)
438  TYPE(xt_xmap), INTENT(in) :: xmap
439  INTEGER,INTENT(in) :: send_dt, recv_dt
440  TYPE(xt_redist),INTENT(out) :: redist
441 
442  INTEGER :: dt
443 
444  IF (send_dt /= recv_dt) &
445  CALL abort('gen_trans: (send_dt /= recv_dt) unsupported', __line__)
446  dt = send_dt
447  redist = xt_redist_p2p_new(xmap, dt)
448  !CALL ut_init_transposition(itemp, dt, itrans)
449 
450  END SUBROUTINE gen_trans
451 
452  SUBROUTINE gen_off_trans(xmap, send_dt, send_off, recv_dt, recv_off, redist)
453  TYPE(xt_xmap), INTENT(in) :: xmap
454  INTEGER,INTENT(in) :: send_dt, recv_dt
455  INTEGER(c_int),INTENT(in) :: send_off(:,:), recv_off(:,:)
456  TYPE(xt_redist),INTENT(out) :: redist
457 
458  !INTEGER :: send_offsets(SIZE(send_off)), recv_offsets(SIZE(recv_off))
459 
460  !send_offsets = RESHAPE(send_off, (/SIZE(send_off)/) )
461  !recv_offsets = RESHAPE(recv_off, (/SIZE(recv_off)/) )
462  IF (recv_dt /= send_dt) &
463  CALL abort('(datatype_in /= datatype_out) not supported', __line__)
464 
465  redist = xt_redist_p2p_off_new(xmap, send_off, recv_off, send_dt);
466  !CALL ut_init_transposition(itemp, send_offsets, recv_offsets, send_dt, recv_dt, itrans)
467 
468  END SUBROUTINE gen_off_trans
469 
470  SUBROUTINE get_window(gval, win)
471  INTEGER(xt_int_kind), INTENT(in) :: gval(:,:)
472  INTEGER(xt_int_kind), INTENT(out) :: win(:,:)
473 
474  INTEGER :: i, j, ig, jg
475 
476  DO j = 1, je
477  jg = p_joff + j
478  DO i = 1, ie
479  ig = p_ioff + i
480  win(i,j) = gval(ig,jg)
481  ENDDO
482  ENDDO
483 
484  END SUBROUTINE get_window
485 
486  SUBROUTINE gen_template(local_src_idx, local_dst_idx, xmap)
487  INTEGER(xt_int_kind), INTENT(in) :: local_src_idx(:,:)
488  INTEGER(xt_int_kind), INTENT(in) :: local_dst_idx(:,:)
489  TYPE(xt_xmap), INTENT(out) :: xmap
490 
491  TYPE(Xt_idxlist) :: src_idxlist, dst_idxlist
492  INTEGER :: src_num, dst_num
493  INTEGER(xt_int_kind) :: cp_src_idx(g_ie, g_je)
494  INTEGER(xt_int_kind) :: cp_dst_idx(g_ie, g_je)
495 
496  src_idxlist = xt_idxvec_new(local_src_idx, g_ie * g_je)
497  src_num = int(xt_idxlist_get_num_indices(src_idxlist))
498  IF (src_num /= g_ie*g_je) CALL abort('unexpected src_num', __line__)
499  CALL xt_idxlist_get_indices(src_idxlist, cp_src_idx)
500  IF (any(cp_src_idx /= local_src_idx)) &
501  CALL abort('idx copy does not match', __line__)
502 
503  dst_idxlist = xt_idxvec_new(local_dst_idx, g_ie * g_je)
504  dst_num = int(xt_idxlist_get_num_indices(dst_idxlist))
505  IF (dst_num /= g_ie*g_je) CALL abort('unexpected dst_num', __line__)
506  CALL xt_idxlist_get_indices(dst_idxlist, cp_dst_idx)
507  IF (any(cp_dst_idx /= local_dst_idx)) &
508  CALL abort('idx copy does not match', __line__)
509 
510  xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
511  CALL xt_idxlist_delete(src_idxlist)
512  CALL xt_idxlist_delete(dst_idxlist)
513 
514  END SUBROUTINE gen_template
515 
516  SUBROUTINE def_tpex_mod_via_idxvec(mvec, mvec_num)
517  TYPE(xt_modifier), INTENT(out) :: mvec(:)
518  INTEGER, INTENT(out) :: mvec_num
519 
520  INTEGER(xt_int_kind) :: g_start_indices(g_ie, g_je)
521  INTEGER(xt_int_kind) :: g_end_indices(g_ie, g_je)
522  TYPE(xt_idxlist) :: g_start_idxlist
523  TYPE(xt_idxlist) :: g_end_idxlist
524 
525  IF (SIZE(mvec)<1) &
526  CALL abort('def_tpex_mod_via_idxvec mvec too small', __line__)
527 
528  CALL id_map(g_start_indices)
529  g_start_idxlist = xt_idxvec_new(g_start_indices, SIZE(g_start_indices))
530 
531  CALL def_exchange(g_start_indices, g_end_indices)
532  g_end_idxlist = xt_idxvec_new(g_end_indices, SIZE(g_end_indices))
533 
534  mvec(1)%extract = g_start_idxlist
535  mvec(1)%subst = g_end_idxlist
536  mvec(1)%mask = 1
537  mvec_num = 1
538 
539  END SUBROUTINE def_tpex_mod_via_idxvec
540 
541  SUBROUTINE def_tpex_mod_via_sections(mvec, mvec_num)
542  TYPE(xt_modifier), INTENT(out) :: mvec(:)
543  INTEGER, INTENT(out) :: mvec_num
544 
545  INTEGER(xt_int_kind), PARAMETER :: gstart_idx = 1_xt_int_kind
546  INTEGER(xt_int_kind), PARAMETER :: gsize(2) &
547  = (/ int(g_ie, xt_int_kind), int(g_je, xt_int_kind) /)
548  INTEGER :: ldx, ldy
549 
550  INTEGER(xt_int_kind) :: g_core_is, g_core_ie, g_core_je
551  INTEGER(xt_int_kind) :: north_halo, im
552 
553  ! global core domain:
554  g_core_is = nhalo + 1
555  g_core_ie = g_ie-nhalo
556  g_core_je = g_je-nhalo
557 
558  im = 0
559 
560  ! global tripolar boundsexchange:
561  IF (with_north_halo) THEN
562 
563  ! north inversion, (maybe with increased north halo)
564  IF (increased_north_halo) THEN
565  north_halo = nhalo+1
566  ELSE
567  north_halo = nhalo
568  ENDIF
569 
570  IF (2*north_halo > g_core_je) &
571  CALL test_abort('def_tpex_mod_via_sections: grid too small '//&
572  '(or halo too large) for tripolar north exchange',filename, __line__)
573 
574  im = im + 1_xt_int_kind
575  IF (SIZE(mvec)<im) CALL abort('(SIZE(mvec)<im)', __line__)
576  ! north border exchange without ew-halos
577  ldx = int(g_core_ie - g_core_is + 1)
578  ldy = int(north_halo)
579  mvec(im)%extract = xt_idxfsection_new(gstart_idx, gsize, &
580  (/ ldx, ldy /), (/g_core_is, 1_xt_int_kind/))
581  mvec(im)%subst = xt_idxfsection_new(gstart_idx, gsize, &
582  (/ -ldx, -ldy /), (/g_core_is, north_halo+1_xt_int_kind/))
583  mvec(im)%mask = 1
584 
585  ! 1. north edge:
586  im = im + 1_xt_int_kind
587  IF (SIZE(mvec)<im) CALL abort('(SIZE(mvec)<im)', __line__)
588  ldx = 1
589  ldy = int(north_halo)
590  mvec(im)%extract = xt_idxfsection_new(gstart_idx, gsize, &
591  (/ ldx, ldy /), (/1_xt_int_kind, 1_xt_int_kind/))
592  mvec(im)%subst = xt_idxfsection_new(gstart_idx, gsize, &
593  (/ -ldx, -ldy /), (/2_xt_int_kind, north_halo+1_xt_int_kind/))
594  mvec(im)%mask = 1
595  ! 2. north edge:
596  im = im + 1_xt_int_kind
597  IF (SIZE(mvec)<im) CALL abort('(SIZE(mvec)<im)', __line__)
598  ldx = 1
599  ldy = int(north_halo)
600  mvec(im)%extract = xt_idxfsection_new(gstart_idx, gsize, &
601  (/ ldx, ldy /), (/int(g_ie, xt_int_kind), 1_xt_int_kind/))
602  mvec(im)%subst = xt_idxfsection_new(gstart_idx, gsize, &
603  (/ -ldx, -ldy /), &
604  (/int(g_ie - 1, xt_int_kind), north_halo+1_xt_int_kind/))
605  mvec(im)%mask = 1
606 
607  ELSE
608 
609  ! nothing to do at the north border
610 
611  ENDIF
612 
613  ! PBC below north border
614  ldx = nhalo
615  ldy = int(int(g_je, xt_int_kind) - north_halo)
616  im = im + 1_xt_int_kind
617  IF (SIZE(mvec)<im) CALL abort('(SIZE(mvec)<im)', __line__)
618  mvec(im)%extract = xt_idxfsection_new(gstart_idx, gsize, &
619  (/ ldx, ldy /), (/1_xt_int_kind, north_halo+1_xt_int_kind/))
620  mvec(im)%subst = xt_idxfsection_new(gstart_idx, gsize, &
621  (/ ldx, ldy /), &
622  (/ g_core_ie - int(ldx, xt_int_kind) + 1_xt_int_kind, &
623  north_halo + 1_xt_int_kind/))
624  mvec(im)%mask = 1
625 
626  im = im + 1_xt_int_kind
627  IF (SIZE(mvec)<im) CALL abort('(SIZE(mvec)<im)', __line__)
628  mvec(im)%extract = xt_idxfsection_new(gstart_idx, gsize, &
629  (/ ldx, ldy /), (/g_core_ie+1_xt_int_kind, north_halo+1_xt_int_kind/))
630  mvec(im)%subst = xt_idxfsection_new(gstart_idx, gsize, &
631  (/ ldx, ldy /), (/ int(ldx, xt_int_kind) + 1_xt_int_kind, &
632  & north_halo+1_xt_int_kind/))
633  mvec(im)%mask = 1
634 
635  mvec_num = int(im)
636 
637  END SUBROUTINE def_tpex_mod_via_sections
638 
639  SUBROUTINE def_exchange(id_in, id_out)
640  INTEGER(xt_int_kind), INTENT(in) :: id_in(:,:)
641  INTEGER(xt_int_kind), INTENT(out) :: id_out(:,:)
642 
643  INTEGER :: i, j
644  INTEGER :: g_core_is, g_core_ie, g_core_js, g_core_je
645  INTEGER :: north_halo
646 
647  ! global core domain:
648  g_core_is = nhalo + 1
649  g_core_ie = g_ie-nhalo
650  g_core_js = nhalo + 1
651  g_core_je = g_je-nhalo
652 
653  ! global tripolar boundsexchange:
654  id_out = undef_index
655  id_out(g_core_is:g_core_ie, g_core_js:g_core_je) &
656  = id_in(g_core_is:g_core_ie, g_core_js:g_core_je)
657 
658  IF (with_north_halo) THEN
659 
660  ! north inversion, (maybe with increased north halo)
661  IF (increased_north_halo) THEN
662  north_halo = nhalo+1
663  ELSE
664  north_halo = nhalo
665  ENDIF
666 
667  IF (2*north_halo > g_core_je) &
668  CALL test_abort('def_exchange: grid too small (or halo too large)'//&
669  'for tripolar north exchange', filename, __line__)
670  DO j = 1, north_halo
671  DO i = g_core_is, g_core_ie
672  id_out(i,j) = id_out(g_core_ie + (g_core_is-i), 2*north_halo + (1-j))
673  ENDDO
674  ENDDO
675 
676  ELSE
677 
678  DO j = 1, nhalo
679  DO i = nhalo+1, g_ie-nhalo
680  id_out(i,j) = id_in(i,j)
681  ENDDO
682  ENDDO
683 
684  ENDIF
685 
686  ! south: no change
687  DO j = g_core_je+1, g_je
688  DO i = nhalo+1, g_ie-nhalo
689  id_out(i,j) = id_in(i,j)
690  ENDDO
691  ENDDO
692 
693  ! PBC
694  DO j = 1, g_je
695  DO i = 1, nhalo
696  id_out(g_core_is-i,j) = id_out(g_core_ie+(1-i),j)
697  ENDDO
698  DO i = 1, nhalo
699  id_out(g_core_ie+i,j) = id_out(nhalo+i,j)
700  ENDDO
701  ENDDO
702 
703  IF (any(id_out == undef_index)) &
704  CALL abort('found undefined indices', __line__)
705 
706  END SUBROUTINE def_exchange
707 
708  SUBROUTINE deco
709  INTEGER :: cx0(0:nprocx-1), cxn(0:nprocx-1)
710  INTEGER :: cy0(0:nprocy-1), cyn(0:nprocy-1)
711 
712  CALL regular_deco(g_ie-2*nhalo, cx0, cxn)
713  CALL regular_deco(g_je-2*nhalo, cy0, cyn)
714 
715  ! process local deco variables:
716  ie = cxn(mypx) + 2*nhalo
717  je = cyn(mypy) + 2*nhalo
718  p_ioff = cx0(mypx)
719  p_joff = cy0(mypy)
720 
721  END SUBROUTINE deco
722 
723 END PROGRAM test_yaxt
724 !
725 ! Local Variables:
726 ! f90-continuation-indent: 5
727 ! coding: utf-8
728 ! indent-tabs-mode: nil
729 ! show-trailing-whitespace: t
730 ! require-trailing-newline: t
731 ! End:
732 !
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
int xt_idxlist_get_num_indices(Xt_idxlist idxlist)
Definition: xt_idxlist.c:98
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
Definition: xt_idxlist.c:102
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
Xt_idxlist xt_idxmod_new(Xt_idxlist patch_idxlist, struct Xt_modifier *modifier, int modifier_num, int *mstate)
generates a new index list based on an index list and a sequence of modifiers
Definition: xt_idxmod.c:61
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_collection_static_new(Xt_redist *redists, int num_redists, const MPI_Aint src_displacements[num_redists], const MPI_Aint dst_displacements[num_redists], MPI_Comm comm)
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)
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)