uniform_partition.f90 7.21 KB
Newer Older
1
2
! uniform_partition.f90 --- compute uniform partitions
!
3
! Copyright  (C)  2010  Thomas Jahns <jahns@dkrz.de>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
!
! Version: 1.0
! Keywords: uniform distribution partition
! Author: Thomas Jahns <jahns@dkrz.de>
! Maintainer: Thomas Jahns <jahns@dkrz.de>
! URL: https://www.dkrz.de/redmine/projects/show/scales-ppm
!
! Redistribution and use in source and binary forms, with or without
! modification, are  permitted provided that the following conditions are
! met:
!
! Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
!
! Neither the name of the DKRZ GmbH nor the names of its contributors
! may be used to endorse or promote products derived from this software
! without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! Commentary:
!
!
!
! Code:
!
44
MODULE uniform_partition
45
  USE ppm_base, ONLY: abort_ppm
46
  USE ppm_extents, ONLY: extent, extent_size, extent_start
47
  USE mo_kind, ONLY: i8
48
49
50
51
52
53
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: uniform_partition_1d, uniform_decomposition_1d, &
       uniform_decomposition_2d
CONTAINS
  !> compute start integer of uniform interval partition
54
55
  PURE FUNCTION uniform_partition_1d_start(set_interval, nparts, part_idx, &
       symmetric) RESULT(start)
56
    INTEGER, INTENT(in) :: nparts
57
    TYPE(extent), INTENT(in) :: set_interval
58
    INTEGER, INTENT(in) :: part_idx
59
60
    LOGICAL, INTENT(in) :: symmetric
    INTEGER :: start, part_offset, sym_part_idx
61

62
    IF (symmetric) THEN
63
64
      sym_part_idx = MERGE(part_idx - 1, nparts - part_idx + 1, &
           part_idx - 1 < nparts/2)
Thomas Jahns's avatar
Thomas Jahns committed
65
      part_offset = INT((INT(extent_size(set_interval), i8)/2_i8 &
66
           &          * INT(sym_part_idx, i8)) / (INT(nparts, i8)/2_i8))
67
68
      IF (part_idx - 1 >= nparts/2) THEN
        part_offset = extent_size(set_interval) - part_offset + 1
69
70
      END IF
    ELSE
71
72
      part_offset = INT((INT(extent_size(set_interval), i8) &
           &             * INT(part_idx - 1, i8)) / INT(nparts, i8))
73
74
    END IF
    start = extent_start(set_interval) + part_offset
75
  END FUNCTION uniform_partition_1d_start
76
77
78

  !> compute nth partition of integer set interval divided into
  !> roughly same sized sub-intervals forming a uniform partitioning
79
80
  PURE FUNCTION uniform_partition_1d(set_interval, nparts, part_idx, &
       symmetric) RESULT(interval)
81
    INTEGER, INTENT(in) :: nparts
82
    TYPE(extent), INTENT(in) :: set_interval
83
    INTEGER, INTENT(in) :: part_idx
84
    LOGICAL, OPTIONAL, INTENT(in) :: symmetric
85

86
    TYPE(extent) :: interval
87
    LOGICAL :: symmetric_pass
88
    INTEGER :: start_part, start_next_part
89
90
91
92
93
94
95
    IF (PRESENT(symmetric)) THEN
      symmetric_pass = symmetric
    ELSE
      symmetric_pass = .FALSE.
    END IF
    start_part = uniform_partition_1d_start(set_interval, nparts, part_idx, &
         symmetric_pass)
96
    start_next_part = uniform_partition_1d_start(set_interval, nparts, &
97
         part_idx + 1, symmetric_pass)
98
    interval = extent(start_part, start_next_part - start_part)
99
100
101
102
103
  END FUNCTION uniform_partition_1d
  !> divide integer set interval into evenly sized sub-intervals
  !> forming a partition
  !>
  SUBROUTINE uniform_decomposition_1d(set_interval, nparts, &
104
       part_idx, partition, all_partitions, symmetric)
105
    INTEGER, INTENT(in) :: nparts
106
    TYPE(extent), INTENT(in) :: set_interval
107
    INTEGER, OPTIONAL, INTENT(in) :: part_idx
108
109
    TYPE(extent), OPTIONAL, INTENT(out) :: partition
    TYPE(extent), OPTIONAL, INTENT(out) :: all_partitions(nparts)
110
    LOGICAL, OPTIONAL, INTENT(in) :: symmetric
111

Thomas Jahns's avatar
Thomas Jahns committed
112
    INTEGER :: i
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
    CHARACTER(len=240) :: msg
    IF (PRESENT(part_idx) .AND. .NOT. PRESENT(partition)) THEN
      msg = 'partition description requested without &
           & destination specifier partition'
      CALL abort_ppm(msg, __FILE__, __LINE__)
    END IF

    IF (.NOT. PRESENT(part_idx) .AND. PRESENT(partition)) THEN
      msg = 'partition description requested without &
           & specified partition id part_idx'
      CALL abort_ppm(msg, __FILE__, __LINE__)
    END IF

    IF (PRESENT(all_partitions)) THEN
      DO i = 1, nparts
128
129
        all_partitions(i) = uniform_partition_1d(set_interval, nparts, i, &
             symmetric=symmetric)
130
131
132
      END DO
      IF (PRESENT(part_idx)) partition = all_partitions(part_idx)
    ELSEIF (PRESENT(part_idx)) THEN
133
134
      partition = uniform_partition_1d(set_interval, nparts, part_idx, &
           symmetric=symmetric)
135
136
137
138
139
140
    END IF
  END SUBROUTINE uniform_decomposition_1d


  SUBROUTINE uniform_decomposition_2d(set_interval_x, set_interval_y, &
       nparts_x, nparts_y, part_idx_x, part_idx_y, partition, &
141
       all_partitions_x, all_partitions_y, symmetric)
142
    TYPE(extent), INTENT(in) :: set_interval_x, set_interval_y
143
144
    INTEGER, INTENT(in) :: nparts_x, nparts_y
    INTEGER, OPTIONAL, INTENT(in) :: part_idx_x, part_idx_y
145
146
    TYPE(extent), OPTIONAL, INTENT(out) :: partition(2)
    TYPE(extent), OPTIONAL, INTENT(out) :: &
147
         all_partitions_x(nparts_x), all_partitions_y(nparts_y)
148
149
    LOGICAL, OPTIONAL, INTENT(in) :: symmetric

150
151
152
153
154
155
156
157
158
159
160
161
162
    CHARACTER(len=240) :: msg

    IF ((PRESENT(part_idx_x) .OR. PRESENT(part_idx_y) .OR. PRESENT(partition))&
         .AND. .NOT. &
         (PRESENT(part_idx_x) .AND. PRESENT(part_idx_y) &
         .AND. PRESENT(partition))) THEN
      msg = "partition description request requires all of arguments &
           &part_idx_x, part_idx_y and partition"
      CALL abort_ppm(msg, __FILE__, __LINE__)
    END IF

    IF (PRESENT(all_partitions_x)) THEN
      CALL uniform_decomposition_1d(set_interval_x, nparts_x, &
163
           all_partitions=all_partitions_x, symmetric=symmetric)
164
      IF (PRESENT(partition)) partition(1) = all_partitions_x(part_idx_x)
165
    ELSEIF (PRESENT(partition)) THEN
166
      partition(1) = uniform_partition_1d(set_interval_x, nparts_x, part_idx_x)
167
168
169
170
    END IF

    IF (PRESENT(all_partitions_y)) THEN
      CALL uniform_decomposition_1d(set_interval_y, nparts_y, &
171
           all_partitions=all_partitions_y, symmetric=symmetric)
172
      IF (PRESENT(partition)) partition(2) = all_partitions_y(part_idx_y)
173
    ELSEIF (PRESENT(partition)) THEN
174
      partition(2) = uniform_partition_1d(set_interval_y, nparts_y, part_idx_y)
175
176
177
178
    END IF
  END SUBROUTINE uniform_decomposition_2d

END MODULE uniform_partition
179
180
181
182
183
!
! Local Variables:
! license-project-url: "https://www.dkrz.de/redmine/projects/show/scales-ppm"
! license-default: "bsd"
! End: