Yet Another eXchange Tool  0.9.0
test_idxlist_utils_f.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 MODULE test_idxlist_utils
48  USE yaxt, ONLY: xt_int_kind, xt_idxlist, xt_idxlist_c2f, xt_idxlist_f2c, &
49  xt_stripe
50  USE ftest_common, ONLY: test_abort
51  USE iso_c_binding, ONLY: c_ptr, c_int, c_size_t
52  IMPLICIT NONE
53  PRIVATE
54  INTERFACE
55  FUNCTION test_err_count() bind(c, name='test_err_count') RESULT(code)
56  IMPORT :: c_int
57  INTEGER(c_int) :: code
58  END FUNCTION test_err_count
59  END INTERFACE
60  PUBLIC :: test_err_count
61  PUBLIC :: check_idxlist, check_stripes, check_offsets, &
62  idxlist_pack_unpack_copy, check_idxlist_copy
63 
64  CHARACTER(len=*), PARAMETER :: filename = 'test_idxlist_utils_f.f90'
65 CONTAINS
66  SUBROUTINE check_idxlist(idxlist, ref_indices)
67  TYPE(xt_idxlist), INTENT(in) :: idxlist
68  INTEGER(xt_int_kind), INTENT(in) :: ref_indices(:)
69 
70  INTEGER :: num_ref_indices
71  INTEGER(xt_int_kind) :: dummy(1)
72  INTEGER(c_int) :: num_ref_indices_c
73 
74  INTERFACE
75  SUBROUTINE check_idxlist_c(idxlist, ref_indices, ref_num_indices) &
76  bind(c, name='check_idxlist')
77  IMPORT :: xt_int_kind, c_ptr, c_int
78  IMPLICIT NONE
79  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
80  INTEGER(xt_int_kind), INTENT(in) :: ref_indices(*)
81  INTEGER(c_int), VALUE, INTENT(in) :: ref_num_indices
82  END SUBROUTINE check_idxlist_c
83  END INTERFACE
84 
85  num_ref_indices = SIZE(ref_indices)
86  IF (num_ref_indices > 0) THEN
87  num_ref_indices_c = int(num_ref_indices, c_int)
88  CALL check_idxlist_c(xt_idxlist_f2c(idxlist), ref_indices, &
89  num_ref_indices_c)
90  ELSE
91  dummy(1) = 0_xt_int_kind
92  CALL check_idxlist_c(xt_idxlist_f2c(idxlist), dummy, &
93  0_c_int)
94  END IF
95  END SUBROUTINE check_idxlist
96 
97  SUBROUTINE check_stripes(stripes, ref_stripes)
98  TYPE(xt_stripe), INTENT(in) :: stripes(:), ref_stripes(:)
99  INTEGER(c_int) :: num_stripes_c, ref_num_stripes_c
100  INTERFACE
101  SUBROUTINE check_stripes_c(stripes, num_stripes, ref_stripes, &
102  ref_num_stripes) bind(c, name='check_stripes')
103  IMPORT :: xt_stripe, c_int
104  IMPLICIT NONE
105  TYPE(xt_stripe), INTENT(in) :: stripes(*), ref_stripes(*)
106  INTEGER(c_int), VALUE, INTENT(in) :: num_stripes, ref_num_stripes
107  END SUBROUTINE check_stripes_c
108  END INTERFACE
109 
110  num_stripes_c = int(SIZE(stripes), c_int)
111  ref_num_stripes_c = int(SIZE(ref_stripes), c_int)
112  CALL check_stripes_c(stripes, num_stripes_c, ref_stripes, ref_num_stripes_c)
113 
114  END SUBROUTINE check_stripes
115 
116  SUBROUTINE check_offsets(offsets_a, offsets_b)
117  INTEGER(c_int), INTENT(in) :: offsets_a(:), offsets_b(:)
118  INTEGER(c_size_t) :: num_offsets_c
119  INTERFACE
120  SUBROUTINE check_offsets_c(num_offsets, offsets_a, offsets_b) &
121  bind(c, name='check_offsets')
122  IMPORT :: c_size_t, c_int
123  IMPLICIT NONE
124  INTEGER(c_size_t), VALUE, INTENT(in) :: num_offsets
125  INTEGER(c_int), INTENT(IN) :: offsets_a(num_offsets), &
126  offsets_b(num_offsets)
127  END SUBROUTINE check_offsets_c
128  END INTERFACE
129 
130  IF (SIZE(offsets_a) /= size(offsets_b)) &
131  CALL test_abort("inequal number of array elements in eq test", &
132  filename, __line__)
133 
134  num_offsets_c = int(SIZE(offsets_a), c_size_t)
135  CALL check_offsets_c(num_offsets_c, offsets_a, offsets_b)
136 
137  END SUBROUTINE check_offsets
138 
139  FUNCTION idxlist_pack_unpack_copy(idxlist) RESULT(idxlist_copy)
140  TYPE(xt_idxlist), INTENT(in) :: idxlist
141  TYPE(xt_idxlist) :: idxlist_copy
142 
143  INTERFACE
144  FUNCTION idxlist_pack_unpack_copy_c(idxlist) RESULT(idxlist_copy) &
145  bind(c, name='idxlist_pack_unpack_copy')
146  IMPORT :: c_ptr
147  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
148  TYPE(c_ptr) :: idxlist_copy
149  END FUNCTION idxlist_pack_unpack_copy_c
150  END INTERFACE
151 
152  idxlist_copy &
153  = xt_idxlist_c2f(idxlist_pack_unpack_copy_c(xt_idxlist_f2c(idxlist)))
154 
155  END FUNCTION idxlist_pack_unpack_copy
156 
157  SUBROUTINE check_idxlist_copy(idxlist, idxlist_copy, ref_indices, ref_stripes)
158  TYPE(xt_idxlist), INTENT(in) :: idxlist, idxlist_copy
159  INTEGER(xt_int_kind), INTENT(in) :: ref_indices(:)
160  TYPE(xt_stripe), INTENT(in) :: ref_stripes(:)
161  INTEGER(c_size_t) :: num_ref_indices_c, num_ref_stripes_c
162  INTERFACE
163  SUBROUTINE check_idxlist_copy_c(idxlist, idxlist_copy, &
164  num_ref_indices, ref_indices, &
165  num_ref_stripes, ref_stripes) bind(c, name='check_idxlist_copy')
166  IMPORT :: c_size_t, c_ptr, xt_int_kind, xt_stripe
167  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist, idxlist_copy
168  INTEGER(c_size_t), VALUE, INTENT(in) :: num_ref_indices, num_ref_stripes
169  INTEGER(xt_int_kind), INTENT(in) :: ref_indices(*)
170  TYPE(xt_stripe), INTENT(in) :: ref_stripes(*)
171  END SUBROUTINE check_idxlist_copy_c
172  END INTERFACE
173  num_ref_indices_c = int(SIZE(ref_indices), c_size_t)
174  num_ref_stripes_c = int(SIZE(ref_stripes), c_size_t)
175  CALL check_idxlist_copy_c(xt_idxlist_f2c(idxlist), &
176  xt_idxlist_f2c(idxlist_copy), num_ref_indices_c, ref_indices, &
177  num_ref_stripes_c, ref_stripes)
178  END SUBROUTINE check_idxlist_copy
179 
180 END MODULE test_idxlist_utils
181 !
182 ! Local Variables:
183 ! f90-continuation-indent: 5
184 ! coding: utf-8
185 ! indent-tabs-mode: nil
186 ! show-trailing-whitespace: t
187 ! require-trailing-newline: t
188 ! End:
189 !
Definition: yaxt.f90:49
Xt_idxlist xt_idxlist_f2c(struct xt_idxlist_f *p)
Definition: yaxt_f2c.c:156