| Directory: | src/ |
|---|---|
| File: | src/xt_idxsection_f.f90 |
| Date: | 2024-11-08 09:02:52 |
| Exec | Total | Coverage | |
|---|---|---|---|
| Lines: | 20 | 35 | 57.1% |
| Branches: | 25 | 54 | 46.3% |
| Line | Branch | Exec | Source |
|---|---|---|---|
| 1 | !> @file xt_idxsection_f.f90 | ||
| 2 | !! @brief Fortran interface to yaxt implementation | ||
| 3 | !! | ||
| 4 | !! @copyright Copyright (C) 2016 Jörg Behrens <behrens@dkrz.de> | ||
| 5 | !! Moritz Hanke <hanke@dkrz.de> | ||
| 6 | !! Thomas Jahns <jahns@dkrz.de> | ||
| 7 | !! | ||
| 8 | !! @author Jörg Behrens <behrens@dkrz.de> | ||
| 9 | !! Moritz Hanke <hanke@dkrz.de> | ||
| 10 | !! Thomas Jahns <jahns@dkrz.de> | ||
| 11 | !! | ||
| 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://dkrz-sw.gitlab-pages.dkrz.de/yaxt/ | ||
| 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 | #include "fc_feature_defs.inc" | ||
| 48 | MODULE xt_idxsection | ||
| 49 | USE iso_c_binding, ONLY: c_int, c_ptr | ||
| 50 | USE xt_core, ONLY: xt_int_kind, xt_abort, i2, i4, i8 | ||
| 51 | USE xt_idxlist_abstract, ONLY: xt_idxlist, xt_idxlist_c2f | ||
| 52 | IMPLICIT NONE | ||
| 53 | PRIVATE | ||
| 54 | PUBLIC :: xt_idxsection_new, xt_idxfsection_new | ||
| 55 | |||
| 56 | INTERFACE xt_idxsection_new | ||
| 57 | MODULE PROCEDURE xt_idxsection_new_a | ||
| 58 | MODULE PROCEDURE xt_idxsection_new_i2 | ||
| 59 | MODULE PROCEDURE xt_idxsection_new_i4 | ||
| 60 | MODULE PROCEDURE xt_idxsection_new_i8 | ||
| 61 | END INTERFACE xt_idxsection_new | ||
| 62 | |||
| 63 | INTERFACE | ||
| 64 | FUNCTION xt_idxsection_new_c(start, num_dimensions, global_size, & | ||
| 65 | local_size, local_start) BIND(c, name='xt_idxsection_new') & | ||
| 66 | RESULT(idxsection) | ||
| 67 | IMPORT :: c_int, c_ptr, xt_idxlist, xt_int_kind | ||
| 68 | INTEGER(xt_int_kind), VALUE, INTENT(in) :: start | ||
| 69 | INTEGER(c_int), VALUE, INTENT(in) :: num_dimensions | ||
| 70 | INTEGER(xt_int_kind), INTENT(in) :: global_size(num_dimensions), & | ||
| 71 | local_start(num_dimensions) | ||
| 72 | INTEGER(c_int), INTENT(in) :: local_size(num_dimensions) | ||
| 73 | TYPE(c_ptr) :: idxsection | ||
| 74 | END FUNCTION xt_idxsection_new_c | ||
| 75 | END INTERFACE | ||
| 76 | |||
| 77 | CHARACTER(len=*), PARAMETER :: filename = 'xt_idxsection_f.f90' | ||
| 78 | CONTAINS | ||
| 79 | |||
| 80 |
2/4✓ Branch 0 taken 129 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 129 times.
✗ Branch 3 not taken.
|
129 | FUNCTION xt_idxsection_new_a(start, global_size, local_size, local_start) & |
| 81 | RESULT(idxsection) | ||
| 82 | INTEGER(xt_int_kind), INTENT(in) :: start, local_start(:), global_size(:) | ||
| 83 | INTEGER, INTENT(in) :: local_size(:) | ||
| 84 | TYPE(xt_idxlist) :: idxsection | ||
| 85 | INTEGER :: num_dimensions | ||
| 86 | INTEGER(c_int) :: num_dimensions_c | ||
| 87 | 129 | num_dimensions = SIZE(global_size) | |
| 88 | IF (SIZE(local_size) /= num_dimensions & | ||
| 89 |
1/2✗ Branch 0 not taken.
✓ Branch 1 taken 129 times.
|
129 | .OR. SIZE(local_start) /= num_dimensions) & |
| 90 | ✗ | CALL xt_abort("non-matching array sizes", filename, __LINE__) | |
| 91 | 129 | num_dimensions_c = INT(num_dimensions, c_int) | |
| 92 | idxsection = xt_idxlist_c2f(& | ||
| 93 | xt_idxsection_new_c(start, num_dimensions_c, global_size, & | ||
| 94 |
7/10✗ Branch 1 not taken.
✓ Branch 2 taken 129 times.
✓ Branch 3 taken 324 times.
✓ Branch 4 taken 129 times.
✓ Branch 8 taken 49 times.
✓ Branch 9 taken 80 times.
✗ Branch 10 not taken.
✓ Branch 11 taken 129 times.
✗ Branch 12 not taken.
✓ Branch 13 taken 129 times.
|
453 | & INT(local_size, c_int), local_start)) |
| 95 |
1/2✓ Branch 0 taken 129 times.
✗ Branch 1 not taken.
|
258 | END FUNCTION xt_idxsection_new_a |
| 96 | |||
| 97 | ✗ | FUNCTION xt_idxsection_new_i2(start, num_dimensions, global_size, & | |
| 98 | ✗ | local_size, local_start) RESULT(idxsection) | |
| 99 | INTEGER(i2), INTENT(in) :: num_dimensions | ||
| 100 | INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), & | ||
| 101 | local_start(num_dimensions) | ||
| 102 | INTEGER, INTENT(in) :: local_size(num_dimensions) | ||
| 103 | TYPE(xt_idxlist) :: idxsection | ||
| 104 | INTEGER(c_int) :: num_dimensions_c | ||
| 105 | |||
| 106 | ✗ | num_dimensions_c = INT(num_dimensions, c_int) | |
| 107 | idxsection = xt_idxlist_c2f(& | ||
| 108 | xt_idxsection_new_c(start, num_dimensions_c, global_size, & | ||
| 109 | ✗ | & INT(local_size, c_int), local_start)) | |
| 110 | ✗ | END FUNCTION xt_idxsection_new_i2 | |
| 111 | |||
| 112 | 555 | FUNCTION xt_idxsection_new_i4(start, num_dimensions, global_size, & | |
| 113 | 555 | local_size, local_start) RESULT(idxsection) | |
| 114 | INTEGER(i4), INTENT(in) :: num_dimensions | ||
| 115 | INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), & | ||
| 116 | local_start(num_dimensions) | ||
| 117 | INTEGER, INTENT(in) :: local_size(num_dimensions) | ||
| 118 | TYPE(xt_idxlist) :: idxsection | ||
| 119 | INTEGER(c_int), PARAMETER :: dummy = 1 | ||
| 120 | INTEGER(c_int) :: num_dimensions_c | ||
| 121 | |||
| 122 | IF (num_dimensions > HUGE(dummy)) & | ||
| 123 | CALL xt_abort("num_dimensions too large", filename, __LINE__) | ||
| 124 | 555 | num_dimensions_c = INT(num_dimensions, c_int) | |
| 125 | idxsection = xt_idxlist_c2f(& | ||
| 126 | xt_idxsection_new_c(start, num_dimensions_c, global_size, & | ||
| 127 |
3/4✓ Branch 0 taken 1117 times.
✓ Branch 1 taken 555 times.
✗ Branch 4 not taken.
✓ Branch 5 taken 555 times.
|
1672 | & INT(local_size, c_int), local_start)) |
| 128 |
1/2✗ Branch 0 not taken.
✓ Branch 1 taken 555 times.
|
1110 | END FUNCTION xt_idxsection_new_i4 |
| 129 | |||
| 130 | ✗ | FUNCTION xt_idxsection_new_i8(start, num_dimensions, global_size, & | |
| 131 | ✗ | local_size, local_start) RESULT(idxsection) | |
| 132 | INTEGER(i8), INTENT(in) :: num_dimensions | ||
| 133 | INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), & | ||
| 134 | local_start(num_dimensions) | ||
| 135 | INTEGER, INTENT(in) :: local_size(num_dimensions) | ||
| 136 | TYPE(xt_idxlist) :: idxsection | ||
| 137 | INTEGER(c_int), PARAMETER :: dummy = 1 | ||
| 138 | INTEGER(c_int) :: num_dimensions_c | ||
| 139 | |||
| 140 | ✗ | IF (num_dimensions > HUGE(dummy)) & | |
| 141 | ✗ | CALL xt_abort("num_dimensions too large", filename, __LINE__) | |
| 142 | ✗ | num_dimensions_c = INT(num_dimensions, c_int) | |
| 143 | idxsection = xt_idxlist_c2f(& | ||
| 144 | xt_idxsection_new_c(start, num_dimensions_c, global_size, & | ||
| 145 | ✗ | & INT(local_size, c_int), local_start)) | |
| 146 | ✗ | END FUNCTION xt_idxsection_new_i8 | |
| 147 | |||
| 148 | !> Fortran style version of \ref xt_idxsection_new. Compared to xt_idxsection_new, here | ||
| 149 | !! the elements of the vector arguments are used in reversed order and the values of the elements | ||
| 150 | !! of local_start are shifted by one. This means that, e.g., to start your local section with | ||
| 151 | !! the global start index you have to set all coords in local_start to ONE instead of ZERO (as it would be required | ||
| 152 | !! in xt_idxsection_new). The local section must be contained within the global index space. | ||
| 153 | !! @param[in] start start index of the global index space | ||
| 154 | !! @param[in] global_size vector holding the global size for each dimension | ||
| 155 | !! @param[in] local_size vector holding the local section size for each dimension | ||
| 156 | !! @param[in] local_start vector holding the coordinates of the section start; lowest coodinate is ONE for each dimension | ||
| 157 |
2/4✓ Branch 0 taken 49 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 49 times.
✗ Branch 3 not taken.
|
49 | FUNCTION xt_idxfsection_new(start, global_size, local_size, local_start) & |
| 158 | RESULT(idxfsection) | ||
| 159 | INTEGER(xt_int_kind), INTENT(in) :: start, global_size(:), local_start(:) | ||
| 160 | INTEGER, INTENT(in) :: local_size(:) | ||
| 161 | TYPE(xt_idxlist) :: idxfsection | ||
| 162 | |||
| 163 | INTEGER :: idim, ndim | ||
| 164 | LOGICAL :: err_state | ||
| 165 | |||
| 166 | 49 | ndim = SIZE(global_size) | |
| 167 |
1/2✗ Branch 0 not taken.
✓ Branch 1 taken 49 times.
|
49 | IF (SIZE(local_size) /= ndim .OR. SIZE(local_start) /= ndim) & |
| 168 | ✗ | CALL xt_abort("non-matching array sizes", filename, __LINE__) | |
| 169 | |||
| 170 | ! check if local indices are a subset of global indices: | ||
| 171 | 49 | err_state = .FALSE. | |
| 172 |
2/2✓ Branch 0 taken 166 times.
✓ Branch 1 taken 49 times.
|
215 | DO idim = 1, ndim |
| 173 | err_state = err_state .OR. (local_start(idim) < 1) .OR. & | ||
| 174 | 215 | (local_start(idim) + local_size(idim) - 1 > global_size(idim)) | |
| 175 | ENDDO | ||
| 176 |
1/2✗ Branch 0 not taken.
✓ Branch 1 taken 49 times.
|
49 | IF (err_state) CALL xt_abort("local indices out of global index space", & |
| 177 | ✗ | filename, __LINE__) | |
| 178 | |||
| 179 | ! Fortran style map of mult-dim coords to indices: | ||
| 180 | ! => reverse order of dimensions and coords starting at 1 (instead of 0 as in c) | ||
| 181 | idxfsection = xt_idxsection_new(start, & | ||
| 182 | global_size(ndim:1:-1), & | ||
| 183 | local_size(ndim:1:-1), & | ||
| 184 |
3/4✗ Branch 0 not taken.
✓ Branch 1 taken 49 times.
✓ Branch 2 taken 166 times.
✓ Branch 3 taken 49 times.
|
215 | local_start(ndim:1:-1) - 1_xt_int_kind ) |
| 185 | |||
| 186 |
1/2✓ Branch 0 taken 49 times.
✗ Branch 1 not taken.
|
98 | END FUNCTION xt_idxfsection_new |
| 187 | |||
| 188 | END MODULE xt_idxsection | ||
| 189 | ! | ||
| 190 | ! Local Variables: | ||
| 191 | ! f90-continuation-indent: 5 | ||
| 192 | ! coding: utf-8 | ||
| 193 | ! indent-tabs-mode: nil | ||
| 194 | ! show-trailing-whitespace: t | ||
| 195 | ! require-trailing-newline: t | ||
| 196 | ! End: | ||
| 197 | ! | ||
| 198 |