Yet Another eXchange Tool  0.9.0
test_idxmod_f.f90
1 
10 !
11 ! Keywords:
12 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
13 ! Thomas Jahns <jahns@dkrz.de>
14 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
15 !
16 ! Redistribution and use in source and binary forms, with or without
17 ! modification, are permitted provided that the following conditions are
18 ! met:
19 !
20 ! Redistributions of source code must retain the above copyright notice,
21 ! this list of conditions and the following disclaimer.
22 !
23 ! Redistributions in binary form must reproduce the above copyright
24 ! notice, this list of conditions and the following disclaimer in the
25 ! documentation and/or other materials provided with the distribution.
26 !
27 ! Neither the name of the DKRZ GmbH nor the names of its contributors
28 ! may be used to endorse or promote products derived from this software
29 ! without specific prior written permission.
30 !
31 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
32 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
33 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
34 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
35 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
36 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
37 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
38 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
39 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
40 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
41 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
42 !
43 PROGRAM test_idxmod_f
44  USE mpi
45  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_idxlist, &
46  xi => xt_int_kind, xt_stripe, &
49  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
50  USE test_idxlist_utils, ONLY: check_idxlist, test_err_count
51  IMPLICIT NONE
52  CHARACTER(len=*), PARAMETER :: filename = 'test_idxmod_f.f90'
53  CALL init_mpi
54  CALL xt_initialize(mpi_comm_world)
55 
56  CALL test_idxvec_modifier
57  CALL test_idxstripes_modifier
58  CALL test_multimod
59 
60  CALL xt_finalize
61 
62  IF (test_err_count() /= 0) CALL test_abort("non-zero error count", &
63  filename, __line__)
64 
65  CALL finish_mpi
66 
67 CONTAINS
68  SUBROUTINE test_idxvec_modifier
69  INTEGER, PARAMETER :: g_src_num = 9, g_dst_num=9, patch_num=7
70 #ifndef __G95__
71  INTEGER(xi) :: i
72  INTEGER(xi), PARAMETER :: &
73  g_src_idx(g_src_num) = (/ (i, i=1,g_src_num) /), &
74  g_dst_idx(g_dst_num) = (/ (i, i=g_dst_num,1,-1) /), &
75 #else
76  INTEGER :: i
77  INTEGER(xi), PARAMETER :: &
78  g_src_idx(g_src_num) = (/ (int(i, xi), i=1,g_src_num) /), &
79  g_dst_idx(g_dst_num) = (/ (int(i, xi), i=g_dst_num,1,-1) /), &
80 #endif
81  patch_idx(patch_num) = (/ 3_xi, 4_xi, 4_xi, 4_xi, 7_xi, 7_xi, 8_xi /)
82  ! idx:{3,4,4,4,7,7,8} -> pos:{2,3,3,3,6,6,7} => idx:{7,6,6,6,3,3,2}
83  INTEGER(xi), PARAMETER :: &
84  ref_mpatch_idx(patch_num) = (/ 7_xi, 6_xi, 6_xi, 6_xi, 3_xi, 3_xi, &
85  2_xi /)
86 
87  TYPE(xt_idxlist) :: g_src_idxlist, g_dst_idxlist, patch_idxlist, &
88  mpatch_idxlist
89  TYPE(xt_modifier) :: modifier(1)
90 
91  g_src_idxlist = xt_idxvec_new(g_src_idx, g_src_num)
92 
93  g_dst_idxlist = xt_idxvec_new(g_dst_idx, g_dst_num)
94 
95  modifier(1) = xt_modifier(g_src_idxlist, g_dst_idxlist, 0)
96 
97  patch_idxlist = xt_idxvec_new(patch_idx, patch_num)
98 
99  mpatch_idxlist = xt_idxmod_new(patch_idxlist, modifier)
100 
101  CALL check_idxlist(mpatch_idxlist, ref_mpatch_idx)
102 
103  CALL xt_idxlist_delete(mpatch_idxlist)
104  CALL xt_idxlist_delete(patch_idxlist)
105  CALL xt_idxlist_delete(g_dst_idxlist)
106  CALL xt_idxlist_delete(g_src_idxlist)
107  END SUBROUTINE test_idxvec_modifier
108 
109  SUBROUTINE test_idxstripes_modifier
110  INTEGER :: i
111  INTEGER, PARAMETER :: patch_num = 8
112  TYPE(xt_stripe), PARAMETER :: &
113  g_src_stripe = xt_stripe(1, 1, 20), &
114  g_dst_stripe = xt_stripe(100, -1, 20)
115  TYPE(xt_idxlist) :: g_src_idxlist, g_dst_idxlist, patch_idxlist, &
116  mpatch_idxlist
117  TYPE(xt_modifier) :: modifier(1)
118  INTEGER :: mstate(patch_num)
119  INTEGER, PARAMETER :: ref_mstate(patch_num) &
120  = (/ 1, ior(2, 32), ior(3, 32), ior(4, 32), ior(5, 32), 6, 7, 8 /)
121  ! inter:{1,3,3,5} => extract_pos:{0,2,2,4} => subst_idx:{100,98,98,96},
122  ! patch_pos:{1,2,3,4} = > mpatch:{0,100,98,98,96,50,100,150}
123  INTEGER(xi), PARAMETER :: &
124  patch_idx(patch_num) = (/ 0_xi, 1_xi, 3_xi, 3_xi, &
125  & 5_xi, 50_xi, 100_xi, 150_xi /), &
126  ref_mpatch_idx(patch_num) = (/ 0_xi, 100_xi, 98_xi, 98_xi, &
127  & 96_xi, 50_xi, 100_xi, 150_xi /)
128 
129  g_src_idxlist = xt_idxstripes_new(g_src_stripe)
130  g_dst_idxlist = xt_idxstripes_new(g_dst_stripe)
131 
132  modifier(1) = xt_modifier(g_src_idxlist, g_dst_idxlist, 32)
133 
134  patch_idxlist = xt_idxvec_new(patch_idx)
135 
136  DO i = 1, patch_num
137  mstate(i) = i
138  END DO
139 
140  mpatch_idxlist = xt_idxmod_new(patch_idxlist, modifier, mstate)
141 
142  CALL check_idxlist(mpatch_idxlist, ref_mpatch_idx)
143 
144  ! check mstate
145  IF (any(mstate(:) /= ref_mstate(:))) &
146  CALL test_abort("mstate(:) /= ref_mstate(:)", filename, __line__)
147  CALL xt_idxlist_delete(mpatch_idxlist)
148  CALL xt_idxlist_delete(patch_idxlist)
149  CALL xt_idxlist_delete(g_dst_idxlist)
150  CALL xt_idxlist_delete(g_src_idxlist)
151  END SUBROUTINE test_idxstripes_modifier
152 
153  ! track modifier usage
154  SUBROUTINE test_multimod
155  INTEGER, PARAMETER :: g1_src_num = 9, g1_dst_num = 9, &
156  g2_src_num = 5, g2_dst_num = 5, patch_num = 6, num_mod = 2
157 #ifndef __G95__
158  INTEGER(xi) :: i
159  INTEGER(xi), PARAMETER :: &
160  g1_src_idx(g1_src_num) = (/ (i, i = 1,g1_src_num) /), &
161  g1_dst_idx(g1_dst_num) = (/ (i, i = g1_dst_num,1,-1) /), &
162 #else
163  INTEGER :: i
164  INTEGER(xi), PARAMETER :: &
165  g1_src_idx(g1_src_num) = (/ (int(i, xi), i = 1,g1_src_num) /), &
166  g1_dst_idx(g1_dst_num) = (/ (int(i, xi), i = g1_dst_num,1,-1) /), &
167 #endif
168  g2_src_idx(g2_src_num) = (/ 1_xi, 2_xi, 8_xi, 9_xi, 10_xi /), &
169  g2_dst_idx(g2_dst_num) = (/ 8_xi, 2_xi, 8_xi, 2_xi, 5_xi /), &
170  patch_idx(patch_num) = (/ 6_xi, 7_xi, 25_xi, 8_xi, 9_xi, 10_xi /), &
171  ! mod1: idx:{6,7,25,8,9,10} -> pos:{5,6,nil,7,8,nil} => idx:{4,3,25,2,1,10}
172  ! mod2: idx:{4,3,25,2,1,10} -> pos:{nil,nil,nil,1,0,4}
173  ! => idx:{4,3,25,2,8,5}
174  ref_mpatch_idx(patch_num) = (/ 4_xi, 3_xi, 25_xi, 2_xi, 8_xi, 5_xi /)
175 
176  TYPE(xt_idxlist) :: mod_idxlist(2,2), patch_idxlist, mpatch_idxlist
177  TYPE(xt_modifier) :: modifier(num_mod)
178  INTEGER :: mstate(patch_num), k
179  INTEGER, PARAMETER :: ref_mstate(patch_num) &
180  = (/ ior(1, 0), ior(1, 0), ior(0, 0), &
181  & ior(1, 2), ior(1, 2), ior(0, 2) /), &
182  src = 1, dst = 2
183 
184  mod_idxlist(1, src) = xt_idxvec_new(g1_src_idx, g1_src_num)
185  mod_idxlist(1, dst) = xt_idxvec_new(g1_dst_idx)
186  mod_idxlist(2, src) = xt_idxvec_new(g2_src_idx)
187  mod_idxlist(2, dst) = xt_idxvec_new(g2_dst_idx, g2_dst_num)
188 
189  patch_idxlist = xt_idxvec_new(patch_idx)
190  ! reset mstate
191  mstate(:) = 0
192 
193  DO k = 1, num_mod
194  modifier(k) = xt_modifier(mod_idxlist(k, src), mod_idxlist(k, dst), &
195  ishft(1, k - 1))
196  END DO
197  mpatch_idxlist = xt_idxmod_new(patch_idxlist, modifier, 2, mstate)
198  CALL check_idxlist(mpatch_idxlist, ref_mpatch_idx)
199 
200  ! check mstate
201  IF (any(mstate(:) /= ref_mstate(:))) &
202  CALL test_abort("mstate(:) /= ref_mstate(:)", filename, __line__)
203  CALL xt_idxlist_delete(mpatch_idxlist)
204  CALL xt_idxlist_delete(patch_idxlist)
205  CALL xt_idxlist_delete(mod_idxlist)
206  END SUBROUTINE test_multimod
207 
208 END PROGRAM test_idxmod_f
209 !
210 ! Local Variables:
211 ! f90-continuation-indent: 5
212 ! coding: utf-8
213 ! indent-tabs-mode: nil
214 ! show-trailing-whitespace: t
215 ! require-trailing-newline: t
216 ! End:
217 !
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
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_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition: xt_idxvec.c:163