Yet Another eXchange Tool  0.9.0
xt_sort_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_sort
49  use, INTRINSIC :: iso_c_binding, only: c_int, c_size_t
50  USE xt_core, ONLY: xt_abort, xt_int_kind
51  IMPLICIT NONE
52  PRIVATE
53 
54  INTERFACE xt_sort_int
55  SUBROUTINE xt_sort_int_f2c(a, n) bind(c, name='xt_sort_int_f2c')
56  IMPORT :: c_int, c_size_t
57  INTEGER(c_size_t), VALUE, INTENT(in) :: n
58  INTEGER(c_int), INTENT(inout) :: a(n)
59  END SUBROUTINE xt_sort_int_f2c
60  MODULE PROCEDURE xt_sort_int_a
61  END INTERFACE xt_sort_int
62  PUBLIC :: xt_sort_int
63 
64  INTERFACE xt_sort_index
65  SUBROUTINE xt_sort_index_f2c(a, n, positions, reset_positions) &
66  bind(c, name='xt_sort_index_f2c')
67  IMPORT :: c_int
68  INTEGER(c_int), VALUE, INTENT(in) :: n, reset_positions
69  INTEGER(c_int), INTENT(inout) :: a(n), positions(n)
70  END SUBROUTINE xt_sort_index_f2c
71  MODULE PROCEDURE xt_sort_index_a_a_l
72  END INTERFACE xt_sort_index
73  PUBLIC :: xt_sort_index
74 
75  INTERFACE xt_sort_permutation
76  SUBROUTINE xt_sort_int_permutation_f2c(a, n, permutation) &
77  bind(c, name='xt_sort_int_permutation_f2c')
78  IMPORT :: c_int, c_size_t
79  INTEGER(c_size_t), VALUE, INTENT(in) :: n
80  INTEGER(c_int), INTENT(inout) :: a(n), permutation(n)
81  END SUBROUTINE xt_sort_int_permutation_f2c
82  MODULE PROCEDURE xt_sort_int_permutation
83  END INTERFACE xt_sort_permutation
84  PUBLIC :: xt_sort_permutation
85 
86  TYPE, BIND(c), PUBLIC :: xt_idxpos
87  INTEGER(xt_int_kind) :: idx
88  INTEGER(c_int) :: pos
89  END TYPE xt_idxpos
90 
91  INTERFACE xt_sort_idxpos
92  SUBROUTINE xt_sort_idxpos_f2c(a, n) bind(c, name='xt_sort_idxpos_f2c')
93  IMPORT :: c_size_t, xt_idxpos
94  INTEGER(c_size_t), VALUE, INTENT(in) :: n
95  TYPE(xt_idxpos), INTENT(inout) :: a(n)
96  END SUBROUTINE xt_sort_idxpos_f2c
97  MODULE PROCEDURE xt_sort_idxpos_a
98  END INTERFACE xt_sort_idxpos
99  PUBLIC :: xt_sort_idxpos
100 
101  CHARACTER(len=*), PARAMETER :: filename = 'xt_sort_f.f90'
102 CONTAINS
103  SUBROUTINE xt_sort_int_a(a)
104  INTEGER(c_int), INTENT(inout) :: a(:)
105  INTEGER :: a_size
106  a_size = SIZE(a)
107  IF (a_size > 1) CALL xt_sort_int_f2c(a, int(a_size, c_size_t))
108  END SUBROUTINE xt_sort_int_a
109 
110  SUBROUTINE xt_sort_index_a_a_l(a, positions, reset_positions)
111  INTEGER(c_int), INTENT(inout) :: a(:), positions(:)
112  LOGICAL, INTENT(in) :: reset_positions
113  INTEGER :: a_size
114  a_size = SIZE(a)
115  IF (a_size > SIZE(positions)) &
116  CALL xt_abort("positions array too small", filename, __line__)
117  IF (a_size > 1) CALL xt_sort_index_f2c(a, int(a_size, c_int), positions, &
118  merge(1_c_int, 0_c_int, reset_positions))
119  END SUBROUTINE xt_sort_index_a_a_l
120 
121  SUBROUTINE xt_sort_idxpos_a(a)
122  TYPE(xt_idxpos), INTENT(inout) :: a(:)
123  INTEGER :: a_size
124  a_size = SIZE(a)
125  IF (a_size > 1) CALL xt_sort_idxpos_f2c(a, int(a_size, c_size_t))
126  END SUBROUTINE xt_sort_idxpos_a
127 
128  SUBROUTINE xt_sort_int_permutation(a, permutation)
129  INTEGER(c_int), INTENT(inout) :: a(:), permutation(:)
130  INTEGER :: a_size
131  a_size = SIZE(a)
132  IF (a_size > 1) CALL xt_sort_int_permutation_f2c(a, int(a_size, c_size_t), &
133  permutation)
134  END SUBROUTINE xt_sort_int_permutation
135 END MODULE xt_sort
136 !
137 ! Local Variables:
138 ! f90-continuation-indent: 5
139 ! coding: utf-8
140 ! indent-tabs-mode: nil
141 ! show-trailing-whitespace: t
142 ! require-trailing-newline: t
143 ! End:
144 !
integer, parameter, public xt_int_kind
Definition: xt_core_f.f90:54
void xt_sort_int_f2c(int *a, size_t n)
Definition: yaxt_f2c.c:136
void xt_sort_index_f2c(Xt_int *a, int n, int *idx, int reset_index)
Definition: yaxt_f2c.c:141
void xt_sort_int_permutation_f2c(int *a, size_t n, int *permutation)
Definition: yaxt_f2c.c:151
void xt_sort_idxpos_f2c(idxpos_type *a, size_t n)
Definition: yaxt_f2c.c:146