Yet Another eXchange Tool  0.9.0
xt_core_f.f90
Go to the documentation of this file.
1 
13 
14 !
15 ! Keywords:
16 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
17 ! Moritz Hanke <hanke@dkrz.de>
18 ! Thomas Jahns <jahns@dkrz.de>
19 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
20 !
21 ! Redistribution and use in source and binary forms, with or without
22 ! modification, are permitted provided that the following conditions are
23 ! met:
24 !
25 ! Redistributions of source code must retain the above copyright notice,
26 ! this list of conditions and the following disclaimer.
27 !
28 ! Redistributions in binary form must reproduce the above copyright
29 ! notice, this list of conditions and the following disclaimer in the
30 ! documentation and/or other materials provided with the distribution.
31 !
32 ! Neither the name of the DKRZ GmbH nor the names of its contributors
33 ! may be used to endorse or promote products derived from this software
34 ! without specific prior written permission.
35 !
36 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
47 !
48 MODULE xt_core
49  use, INTRINSIC :: iso_c_binding, only: c_char, c_null_char, c_int, &
50  c_long, c_short, c_long_long
51  USE xt_mpi, ONLY: xt_int_fc_mpidt, xt_mpi_fint_kind
52  IMPLICIT NONE
53  PRIVATE
54  INTEGER, PUBLIC, PARAMETER :: xt_int_kind = xt_int_fc_kind
55  INTEGER, PUBLIC, PARAMETER :: pi2 = 4
56  INTEGER, PUBLIC, PARAMETER :: pi4 = 9
57  INTEGER, PUBLIC, PARAMETER :: pi8 = 14
58  INTEGER, PUBLIC, PARAMETER :: i2 = selected_int_kind(pi2)
59  INTEGER, PUBLIC, PARAMETER :: i4 = selected_int_kind(pi4)
60  INTEGER, PUBLIC, PARAMETER :: i8 = selected_int_kind(pi8)
61  PUBLIC :: xt_initialize, xt_finalize, xt_abort, xt_get_default_comm, char
62  PUBLIC :: xt_initialized, xt_finalized
63  PUBLIC :: xt_slice_c_loc
64  PUBLIC :: OPERATOR(==), OPERATOR(/=)
65 
66  PUBLIC :: xt_mpi_fint_kind
67  INTEGER, PUBLIC, PARAMETER :: xt_int_mpidt = xt_int_fc_mpidt
68  INTEGER(xt_int_kind), PARAMETER :: dummy = 0_xt_int_kind
71  INTEGER, PUBLIC, PARAMETER :: xt_int_dec_len &
72  = ceiling(1.0 + real(digits(dummy)) * log10(real(radix(dummy))))
73  CHARACTER(9), PARAMETER :: xt_stripe_tag = 'xt_stripe'
75  INTEGER, PUBLIC, PARAMETER :: xt_stripe2s_len &
76  = len(xt_stripe_tag) + 2 + 4 + 3 * xt_int_dec_len
77 
78  TYPE, BIND(C), PUBLIC :: xt_stripe
79  INTEGER(xt_int_kind) :: start
80  INTEGER(xt_int_kind) :: stride
81  INTEGER(c_int) :: nstrides
82  END TYPE xt_stripe
83 
84  TYPE, BIND(C), PUBLIC :: xt_bounds
85  INTEGER(xt_int_kind) :: start, size
86  END TYPE xt_bounds
87 
91  TYPE, BIND(c), PUBLIC :: xt_pos_ext
92  INTEGER(c_int) :: start, size
93  END TYPE xt_pos_ext
94 
95  INTERFACE
96 
97  FUNCTION xt_get_default_comm() RESULT(comm) &
98  bind(c, name='xt_get_default_comm_f')
99  IMPORT :: xt_mpi_fint_kind
100  IMPLICIT NONE
101  INTEGER(xt_mpi_fint_kind) :: comm
102  END FUNCTION xt_get_default_comm
103 
104  SUBROUTINE xt_initialize(default_comm) bind(C, name='xt_initialize_f')
105  import:: c_int, xt_mpi_fint_kind
106  IMPLICIT NONE
107  INTEGER(xt_mpi_fint_kind), INTENT(in) :: default_comm
108  END SUBROUTINE xt_initialize
109 
110  SUBROUTINE xt_finalize() bind(C, name='xt_finalize')
111  END SUBROUTINE xt_finalize
112 
113  SUBROUTINE xt_restore_default_abort_hndl
114  END SUBROUTINE xt_restore_default_abort_hndl
115 
116  END INTERFACE
117 
118  INTERFACE xt_abort
119  MODULE PROCEDURE xt_abort4
120  MODULE PROCEDURE xt_abort3
121  END INTERFACE xt_abort
122 
123  INTERFACE
124  SUBROUTINE xt_abort_c(comm, msg, source, line) bind(c, name='xt_abort_f')
125  IMPORT :: c_char, c_int, xt_mpi_fint_kind
126  IMPLICIT NONE
127  INTEGER(xt_mpi_fint_kind), VALUE, INTENT(in):: comm
128  CHARACTER(kind=c_char), DIMENSION(*), INTENT(in) :: msg
129  CHARACTER(kind=c_char), DIMENSION(*), INTENT(in) :: source
130  INTEGER(xt_mpi_fint_kind), VALUE, INTENT(in) :: line
131  END SUBROUTINE xt_abort_c
132  END INTERFACE
133 
134  INTERFACE char
135  MODULE PROCEDURE xt_stripe2char
136  END INTERFACE char
137 
138  INTERFACE OPERATOR(==)
139  MODULE PROCEDURE xt_pos_ext_eq
140  END INTERFACE OPERATOR(==)
141 
142  INTERFACE OPERATOR(/=)
143  MODULE PROCEDURE xt_pos_ext_ne
144  END INTERFACE OPERATOR(/=)
145 
146  EXTERNAL :: xt_slice_c_loc
147 
148  PUBLIC :: set_abort_handler, xt_restore_default_abort_hndl
149 
150 CONTAINS
151 
152  SUBROUTINE xt_abort4(comm, msg, source, line)
153  INTEGER, INTENT(in) :: comm
154  CHARACTER(len=*), INTENT(in) :: msg
155  CHARACTER(len=*), INTENT(in) :: source
156  INTEGER, INTENT(in) :: line
157  CALL xt_abort_c(comm, trim(msg)//c_null_char, &
158  trim(source)//c_null_char, int(line, c_int))
159  END SUBROUTINE xt_abort4
160 
161  SUBROUTINE xt_abort3(msg, source, line)
162  CHARACTER(len=*), INTENT(in) :: msg
163  CHARACTER(len=*), INTENT(in) :: source
164  INTEGER, INTENT(in) :: line
165  CALL xt_abort_c(xt_get_default_comm(), trim(msg)//c_null_char, &
166  trim(source)//c_null_char, int(line, c_int))
167  END SUBROUTINE xt_abort3
168 
169  ELEMENTAL FUNCTION xt_stripe2char(stripe) RESULT(str)
170  CHARACTER(len=xt_stripe2s_len) :: str
171  TYPE(xt_stripe), INTENT(in) :: stripe
172  WRITE (str, '(2a,3(i0,a))') xt_stripe_tag, '(', stripe%start, ', ', &
173  stripe%stride, ', ', stripe%nstrides, ')'
174  END FUNCTION xt_stripe2char
175 
176  FUNCTION xt_initialized() RESULT(is_initialized)
177  LOGICAL :: is_initialized
178  INTERFACE
179  FUNCTION xt_initialized_c() bind(c, name='xt_initialized') &
180  result(is_initialized)
181  IMPORT :: c_int
182  INTEGER(c_int) :: is_initialized
183  END FUNCTION xt_initialized_c
184  END INTERFACE
185  is_initialized = xt_initialized_c() /= 0
186  END FUNCTION xt_initialized
187 
188  FUNCTION xt_finalized() RESULT(is_finalized)
189  LOGICAL :: is_finalized
190  INTERFACE
191  FUNCTION xt_finalized_c() bind(c, name='xt_finalized') &
192  result(is_finalized)
193  IMPORT :: c_int
194  INTEGER(c_int) :: is_finalized
195  END FUNCTION xt_finalized_c
196  END INTERFACE
197  is_finalized = xt_finalized_c() /= 0
198  END FUNCTION xt_finalized
199 
200  ELEMENTAL FUNCTION xt_pos_ext_eq(a, b) RESULT(p)
201  TYPE(xt_pos_ext), INTENT(in) :: a, b
202  LOGICAL :: p
203  p = a%start == b%start .AND. (a%size == b%size &
204  .OR. (abs(a%size) == 1 .AND. abs(a%size) == abs(b%size)))
205  END FUNCTION xt_pos_ext_eq
206 
207  ELEMENTAL FUNCTION xt_pos_ext_ne(a, b) RESULT(p)
208  TYPE(xt_pos_ext), INTENT(in) :: a, b
209  LOGICAL :: p
210  p = a%start /= b%start .OR. (a%size /= b%size &
211  .AND. .NOT. (abs(a%size) == 1 .AND. abs(a%size) == abs(b%size)))
212  END FUNCTION xt_pos_ext_ne
213 
215  SUBROUTINE set_abort_handler(f)
216  INTERFACE
217  SUBROUTINE f(comm, msg, source, line)
218  INTEGER, INTENT(in) :: comm, line
219  CHARACTER(len=*), INTENT(in) :: msg, source
220  END SUBROUTINE f
221  SUBROUTINE xt_set_abort_handler(f)
222  INTERFACE
223  SUBROUTINE f(comm, msg, source, line)
224  INTEGER, INTENT(in) :: comm, line
225  CHARACTER(len=*), INTENT(in) :: msg, source
226  END SUBROUTINE f
227  END INTERFACE
228  END SUBROUTINE xt_set_abort_handler
229  END INTERFACE
230  CALL xt_set_abort_handler(f)
231  END SUBROUTINE set_abort_handler
232 
233 END MODULE xt_core
234 !
235 ! Local Variables:
236 ! f90-continuation-indent: 5
237 ! coding: utf-8
238 ! indent-tabs-mode: nil
239 ! show-trailing-whitespace: t
240 ! require-trailing-newline: t
241 ! End:
242 !
integer, parameter, public xt_stripe2s_len
maximal length of string xt_stripe(a, b, c)
Definition: xt_core_f.f90:75
subroutine, public set_abort_handler(f)
set routine f to use as abort function which is called on xt_abort
Definition: xt_core_f.f90:216
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 xt_int_mpidt
Definition: xt_core_f.f90:67
integer, parameter, public i4
Definition: xt_core_f.f90:59
integer, parameter, public pi4
Definition: xt_core_f.f90:56
integer, parameter, public xt_int_dec_len
number of decimal places needed to print any variable of type INTEGER(xt_int_kind)
Definition: xt_core_f.f90:71
external, public xt_slice_c_loc
Definition: xt_core_f.f90:146
integer, parameter, public i2
Definition: xt_core_f.f90:58
integer, parameter, public pi2
Definition: xt_core_f.f90:55
integer, parameter, public pi8
Definition: xt_core_f.f90:57
integer, parameter xt_mpi_fint_kind
Definition: xt_mpi_f.f90:53
describes range of positions starting with start up to start + size - 1 i.e. [start,...
Definition: xt_core_f.f90:91
int xt_finalized(void)
Definition: xt_init.c:113
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
int xt_initialized(void)
Definition: xt_init.c:107
void xt_finalize(void)
Definition: xt_init.c:89