Yet Another eXchange Tool  0.9.0
xt_idxsection_f.f90
Go to the documentation of this file.
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 !
48  USE iso_c_binding, ONLY: c_int, c_ptr
49  USE xt_core, ONLY: xt_int_kind, xt_abort, i2, i4, i8
51  IMPLICIT NONE
52  PRIVATE
54 
55  INTERFACE xt_idxsection_new
56  MODULE PROCEDURE xt_idxsection_new_a
57  MODULE PROCEDURE xt_idxsection_new_i2
58  MODULE PROCEDURE xt_idxsection_new_i4
59  MODULE PROCEDURE xt_idxsection_new_i8
60  END INTERFACE xt_idxsection_new
61 
62  INTERFACE
63  FUNCTION xt_idxsection_new_c(start, num_dimensions, global_size, &
64  local_size, local_start) bind(c, name='xt_idxsection_new') &
65  result(idxsection)
66  IMPORT :: c_int, c_ptr, xt_idxlist, xt_int_kind
67  INTEGER(xt_int_kind), VALUE, INTENT(in) :: start
68  INTEGER(c_int), VALUE, INTENT(in) :: num_dimensions
69  INTEGER(xt_int_kind), INTENT(in) :: global_size(num_dimensions), &
70  local_start(num_dimensions)
71  INTEGER(c_int), INTENT(in) :: local_size(num_dimensions)
72  TYPE(c_ptr) :: idxsection
73  END FUNCTION xt_idxsection_new_c
74  END INTERFACE
75 
76  CHARACTER(len=*), PARAMETER :: filename = 'xt_idxsection_f.f90'
77 CONTAINS
78 
79  FUNCTION xt_idxsection_new_a(start, global_size, local_size, local_start) &
80  result(idxsection)
81  INTEGER(xt_int_kind), INTENT(in) :: start, local_start(:), global_size(:)
82  INTEGER, INTENT(in) :: local_size(:)
83  TYPE(xt_idxlist) :: idxsection
84  INTEGER :: num_dimensions
85  INTEGER(c_int) :: num_dimensions_c
86  num_dimensions = SIZE(global_size)
87  IF (SIZE(local_size) /= num_dimensions &
88  .OR. SIZE(local_start) /= num_dimensions) &
89  CALL xt_abort("non-matching array sizes", filename, __line__)
90  num_dimensions_c = int(num_dimensions, c_int)
91  idxsection = xt_idxlist_c2f(&
92  xt_idxsection_new_c(start, num_dimensions_c, global_size, &
93  & int(local_size, c_int), local_start))
94  END FUNCTION xt_idxsection_new_a
95 
96  FUNCTION xt_idxsection_new_i2(start, num_dimensions, global_size, &
97  local_size, local_start) RESULT(idxsection)
98  INTEGER(i2), INTENT(in) :: num_dimensions
99  INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), &
100  local_start(num_dimensions)
101  INTEGER, INTENT(in) :: local_size(num_dimensions)
102  TYPE(xt_idxlist) :: idxsection
103  INTEGER(c_int) :: num_dimensions_c
104 
105  num_dimensions_c = int(num_dimensions, c_int)
106  idxsection = xt_idxlist_c2f(&
107  xt_idxsection_new_c(start, num_dimensions_c, global_size, &
108  & int(local_size, c_int), local_start))
109  END FUNCTION xt_idxsection_new_i2
110 
111  FUNCTION xt_idxsection_new_i4(start, num_dimensions, global_size, &
112  local_size, local_start) RESULT(idxsection)
113  INTEGER(i4), INTENT(in) :: num_dimensions
114  INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), &
115  local_start(num_dimensions)
116  INTEGER, INTENT(in) :: local_size(num_dimensions)
117  TYPE(xt_idxlist) :: idxsection
118  INTEGER(c_int), PARAMETER :: dummy = 1
119  INTEGER(c_int) :: num_dimensions_c
120 
121  IF (num_dimensions > huge(dummy)) &
122  CALL xt_abort("num_dimensions too large", filename, __line__)
123  num_dimensions_c = int(num_dimensions, c_int)
124  idxsection = xt_idxlist_c2f(&
125  xt_idxsection_new_c(start, num_dimensions_c, global_size, &
126  & int(local_size, c_int), local_start))
127  END FUNCTION xt_idxsection_new_i4
128 
129  FUNCTION xt_idxsection_new_i8(start, num_dimensions, global_size, &
130  local_size, local_start) RESULT(idxsection)
131  INTEGER(i8), INTENT(in) :: num_dimensions
132  INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), &
133  local_start(num_dimensions)
134  INTEGER, INTENT(in) :: local_size(num_dimensions)
135  TYPE(xt_idxlist) :: idxsection
136  INTEGER(c_int), PARAMETER :: dummy = 1
137  INTEGER(c_int) :: num_dimensions_c
138 
139  IF (num_dimensions > huge(dummy)) &
140  CALL xt_abort("num_dimensions too large", filename, __line__)
141  num_dimensions_c = int(num_dimensions, c_int)
142  idxsection = xt_idxlist_c2f(&
143  xt_idxsection_new_c(start, num_dimensions_c, global_size, &
144  & int(local_size, c_int), local_start))
145  END FUNCTION xt_idxsection_new_i8
146 
156  FUNCTION xt_idxfsection_new(start, global_size, local_size, local_start) &
157  result(idxfsection)
158  INTEGER(xt_int_kind), INTENT(in) :: start, global_size(:), local_start(:)
159  INTEGER, INTENT(in) :: local_size(:)
160  TYPE(xt_idxlist) :: idxfsection
161 
162  INTEGER :: idim, ndim
163  LOGICAL :: err_state
164 
165  ndim = SIZE(global_size)
166  IF (SIZE(local_size) /= ndim .OR. SIZE(local_start) /= ndim) &
167  CALL xt_abort("non-matching array sizes", filename, __line__)
168 
169  ! check if local indices are a subset of global indices:
170  err_state = .false.
171  DO idim = 1, ndim
172  err_state = err_state .OR. (local_start(idim) < 1) .OR. &
173  (local_start(idim) + local_size(idim) - 1 > global_size(idim))
174  ENDDO
175  IF (err_state) CALL xt_abort("local indices out of global index space", &
176  filename, __line__)
177 
178  ! Fortran style map of mult-dim coords to indices:
179  ! => reverse order of dimensions and coords starting at 1 (instead of 0 as in c)
180  idxfsection = xt_idxsection_new(start, &
181  global_size(ndim:1:-1), &
182  local_size(ndim:1:-1), &
183  local_start(ndim:1:-1) - 1_xt_int_kind )
184 
185  END FUNCTION xt_idxfsection_new
186 
187 END MODULE xt_idxsection
188 !
189 ! Local Variables:
190 ! f90-continuation-indent: 5
191 ! coding: utf-8
192 ! indent-tabs-mode: nil
193 ! show-trailing-whitespace: t
194 ! require-trailing-newline: t
195 ! End:
196 !
integer, parameter, public i8
Definition: xt_core_f.f90:60
integer, parameter, public xt_int_kind
Definition: xt_core_f.f90:54
integer, parameter, public i4
Definition: xt_core_f.f90:59
integer, parameter, public i2
Definition: xt_core_f.f90:58
type(xt_idxlist) function, public xt_idxlist_c2f(idxlist)
type(xt_idxlist) function, public xt_idxfsection_new(start, global_size, local_size, local_start)
Fortran style version of xt_idxsection_new. Compared to xt_idxsection_new, here the elements of the v...
Xt_idxlist xt_idxsection_new(Xt_int start, int num_dimensions, const Xt_int global_size[num_dimensions], const int local_size[num_dimensions], const Xt_int local_start[num_dimensions])