Yet Another eXchange Tool 0.11.4
Loading...
Searching...
No Matches
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://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
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#include "fc_feature_defs.inc"
44PROGRAM test_idxmod_f
45 USE mpi
46 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_idxlist, &
47 xi => xt_int_kind, xt_stripe, &
50 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
51 USE test_idxlist_utils, ONLY: check_idxlist, test_err_count
52 IMPLICIT NONE
53 CHARACTER(len=*), PARAMETER :: filename = 'test_idxmod_f.f90'
54 CALL init_mpi
55 CALL xt_initialize(mpi_comm_world)
56
57 CALL test_idxvec_modifier
58 CALL test_idxstripes_modifier
59 CALL test_multimod
60
61 CALL xt_finalize
62
63 IF (test_err_count() /= 0) CALL test_abort("non-zero error count", &
64 filename, __line__)
65
66 CALL finish_mpi
67
68CONTAINS
69 SUBROUTINE test_idxvec_modifier
70 INTEGER, PARAMETER :: g_src_num = 9, g_dst_num=9, patch_num=7
71#ifndef __G95__
72 INTEGER(xi) :: i
73 INTEGER(xi), PARAMETER :: &
74 g_src_idx(g_src_num) = (/ (i, i=1,g_src_num) /), &
75 g_dst_idx(g_dst_num) = (/ (i, i=g_dst_num,1,-1) /), &
76#else
77 INTEGER :: i
78 INTEGER(xi), PARAMETER :: &
79 g_src_idx(g_src_num) = (/ (int(i, xi), i=1,g_src_num) /), &
80 g_dst_idx(g_dst_num) = (/ (int(i, xi), i=g_dst_num,1,-1) /), &
81#endif
82 patch_idx(patch_num) = (/ 3_xi, 4_xi, 4_xi, 4_xi, 7_xi, 7_xi, 8_xi /)
83 ! idx:{3,4,4,4,7,7,8} -> pos:{2,3,3,3,6,6,7} => idx:{7,6,6,6,3,3,2}
84 INTEGER(xi), PARAMETER :: &
85 ref_mpatch_idx(patch_num) = (/ 7_xi, 6_xi, 6_xi, 6_xi, 3_xi, 3_xi, &
86 2_xi /)
87
88 TYPE(xt_idxlist) :: g_src_idxlist, g_dst_idxlist, patch_idxlist, &
89 mpatch_idxlist
90 TYPE(xt_modifier) :: modifier(1)
91
92 g_src_idxlist = xt_idxvec_new(g_src_idx, g_src_num)
93
94 g_dst_idxlist = xt_idxvec_new(g_dst_idx, g_dst_num)
95
96 modifier(1) = xt_modifier(g_src_idxlist, g_dst_idxlist, 0)
97
98 patch_idxlist = xt_idxvec_new(patch_idx, patch_num)
99
100 mpatch_idxlist = xt_idxmod_new(patch_idxlist, modifier)
101
102 CALL check_idxlist(mpatch_idxlist, ref_mpatch_idx)
103
104 CALL xt_idxlist_delete(mpatch_idxlist)
105 CALL xt_idxlist_delete(patch_idxlist)
106 CALL xt_idxlist_delete(g_dst_idxlist)
107 CALL xt_idxlist_delete(g_src_idxlist)
108 END SUBROUTINE test_idxvec_modifier
109
110 SUBROUTINE test_idxstripes_modifier
111 INTEGER :: i
112 INTEGER, PARAMETER :: patch_num = 8
113 TYPE(xt_stripe), PARAMETER :: &
114 g_src_stripe = xt_stripe(1, 1, 20), &
115 g_dst_stripe = xt_stripe(100, -1, 20)
116 TYPE(xt_idxlist) :: g_src_idxlist, g_dst_idxlist, patch_idxlist, &
117 mpatch_idxlist
118 TYPE(xt_modifier) :: modifier(1)
119 INTEGER :: mstate(patch_num)
120 INTEGER, PARAMETER :: ref_mstate(patch_num) &
121 = (/ 1, ior(2, 32), ior(3, 32), ior(4, 32), ior(5, 32), 6, 7, 8 /)
122 ! inter:{1,3,3,5} => extract_pos:{0,2,2,4} => subst_idx:{100,98,98,96},
123 ! patch_pos:{1,2,3,4} = > mpatch:{0,100,98,98,96,50,100,150}
124 INTEGER(xi), PARAMETER :: &
125 patch_idx(patch_num) = (/ 0_xi, 1_xi, 3_xi, 3_xi, &
126 & 5_xi, 50_xi, 100_xi, 150_xi /), &
127 ref_mpatch_idx(patch_num) = (/ 0_xi, 100_xi, 98_xi, 98_xi, &
128 & 96_xi, 50_xi, 100_xi, 150_xi /)
129
130 g_src_idxlist = xt_idxstripes_new(g_src_stripe)
131 g_dst_idxlist = xt_idxstripes_new(g_dst_stripe)
132
133 modifier(1) = xt_modifier(g_src_idxlist, g_dst_idxlist, 32)
134
135 patch_idxlist = xt_idxvec_new(patch_idx)
136
137 DO i = 1, patch_num
138 mstate(i) = i
139 END DO
140
141 mpatch_idxlist = xt_idxmod_new(patch_idxlist, modifier, mstate)
142
143 CALL check_idxlist(mpatch_idxlist, ref_mpatch_idx)
144
145 ! check mstate
146 IF (any(mstate(:) /= ref_mstate(:))) &
147 CALL test_abort("mstate(:) /= ref_mstate(:)", filename, __line__)
148 CALL xt_idxlist_delete(mpatch_idxlist)
149 CALL xt_idxlist_delete(patch_idxlist)
150 CALL xt_idxlist_delete(g_dst_idxlist)
151 CALL xt_idxlist_delete(g_src_idxlist)
152 END SUBROUTINE test_idxstripes_modifier
153
154 ! track modifier usage
155 SUBROUTINE test_multimod
156 INTEGER, PARAMETER :: g1_src_num = 9, g1_dst_num = 9, &
157 g2_src_num = 5, g2_dst_num = 5, patch_num = 6, num_mod = 2
158#ifndef __G95__
159 INTEGER(xi) :: i
160 INTEGER(xi), PARAMETER :: &
161 g1_src_idx(g1_src_num) = (/ (i, i = 1,g1_src_num) /), &
162 g1_dst_idx(g1_dst_num) = (/ (i, i = g1_dst_num,1,-1) /), &
163#else
164 INTEGER :: i
165 INTEGER(xi), PARAMETER :: &
166 g1_src_idx(g1_src_num) = (/ (int(i, xi), i = 1,g1_src_num) /), &
167 g1_dst_idx(g1_dst_num) = (/ (int(i, xi), i = g1_dst_num,1,-1) /), &
168#endif
169 g2_src_idx(g2_src_num) = (/ 1_xi, 2_xi, 8_xi, 9_xi, 10_xi /), &
170 g2_dst_idx(g2_dst_num) = (/ 8_xi, 2_xi, 8_xi, 2_xi, 5_xi /), &
171 patch_idx(patch_num) = (/ 6_xi, 7_xi, 25_xi, 8_xi, 9_xi, 10_xi /), &
172 ! mod1: idx:{6,7,25,8,9,10} -> pos:{5,6,nil,7,8,nil} => idx:{4,3,25,2,1,10}
173 ! mod2: idx:{4,3,25,2,1,10} -> pos:{nil,nil,nil,1,0,4}
174 ! => idx:{4,3,25,2,8,5}
175 ref_mpatch_idx(patch_num) = (/ 4_xi, 3_xi, 25_xi, 2_xi, 8_xi, 5_xi /)
176
177 TYPE(xt_idxlist) :: mod_idxlist(2,2), patch_idxlist, mpatch_idxlist
178 TYPE(xt_modifier) :: modifier(num_mod)
179 INTEGER :: mstate(patch_num), k
180 INTEGER, PARAMETER :: ref_mstate(patch_num) &
181 = (/ ior(1, 0), ior(1, 0), ior(0, 0), &
182 & ior(1, 2), ior(1, 2), ior(0, 2) /), &
183 src = 1, dst = 2
184
185 mod_idxlist(1, src) = xt_idxvec_new(g1_src_idx, g1_src_num)
186 mod_idxlist(1, dst) = xt_idxvec_new(g1_dst_idx)
187 mod_idxlist(2, src) = xt_idxvec_new(g2_src_idx)
188 mod_idxlist(2, dst) = xt_idxvec_new(g2_dst_idx, g2_dst_num)
189
190 patch_idxlist = xt_idxvec_new(patch_idx)
191 ! reset mstate
192 mstate(:) = 0
193
194 DO k = 1, num_mod
195 modifier(k) = xt_modifier(mod_idxlist(k, src), mod_idxlist(k, dst), &
196 ishft(1, k - 1))
197 END DO
198 mpatch_idxlist = xt_idxmod_new(patch_idxlist, modifier, 2, mstate)
199 CALL check_idxlist(mpatch_idxlist, ref_mpatch_idx)
200
201 ! check mstate
202 IF (any(mstate(:) /= ref_mstate(:))) &
203 CALL test_abort("mstate(:) /= ref_mstate(:)", filename, __line__)
204 CALL xt_idxlist_delete(mpatch_idxlist)
205 CALL xt_idxlist_delete(patch_idxlist)
206 CALL xt_idxlist_delete(mod_idxlist)
207 END SUBROUTINE test_multimod
208
209END PROGRAM test_idxmod_f
210!
211! Local Variables:
212! f90-continuation-indent: 5
213! coding: utf-8
214! indent-tabs-mode: nil
215! show-trailing-whitespace: t
216! require-trailing-newline: t
217! End:
218!
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
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:62
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:213