Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!! !!!!
4 : !!!! ParaMonte: Parallel Monte Carlo and Machine Learning Library. !!!!
5 : !!!! !!!!
6 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab !!!!
7 : !!!! !!!!
8 : !!!! This file is part of the ParaMonte library. !!!!
9 : !!!! !!!!
10 : !!!! LICENSE !!!!
11 : !!!! !!!!
12 : !!!! https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md !!!!
13 : !!!! !!!!
14 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 :
17 : !> \brief
18 : !> This file contains the implementation details of the routines under the generic interfaces of [pm_arrayResize](@ref pm_arrayResize).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \FatemehBagheri, Wednesday 12:20 AM, October 13, 2021, Dallas, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Set the procedure names.
28 : #if setResized_ENABLED
29 : character(*, SK), parameter :: PROCEDURE_NAME = SK_"@setResized()"
30 : #elif setRefilled_ENABLED
31 : character(*, SK), parameter :: PROCEDURE_NAME = SK_"@setRefilled()"
32 : #elif setRebound_ENABLED
33 : character(*, SK), parameter :: PROCEDURE_NAME = SK_"@setRebound()"
34 : #elif setRebilled_ENABLED
35 : character(*, SK), parameter :: PROCEDURE_NAME = SK_"@setRebilled()"
36 : #else
37 : #error "Unrecognized interface."
38 : #endif
39 : integer :: stat
40 : ! Set the lower bound of the new `array` for fixed lower bound routines.
41 : #if setResized_ENABLED || setRefilled_ENABLED
42 : #define lb lbold
43 : #endif
44 :
45 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
46 : ! Set the dimensionality of `array` and the allocation dimension and define `array` bounds and copy slices.
47 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
48 :
49 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 : #if D0_ENABLED && (setResized_ENABLED || setRefilled_ENABLED)
51 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
52 :
53 : #define ALL(X) X
54 : #define GET_SHAPE(X)len(X, IK)
55 : #define ARRAY_SLICE array(lbcold : ubcold)
56 : #define SET_DIM(OBJECT) character(ub,SKC) :: OBJECT
57 : #define TEMP_SLICE temp(lbc : lbc - lbcold + ubcold)
58 : integer(IK), parameter :: lbold = 1_IK
59 : integer(IK) :: ubold, ub
60 : #if SLDD_ENABLED || SDDD_ENABLED || DDDD_ENABLED
61 : integer(IK) :: lbcold, ubcold
62 : #if SDDD_ENABLED || DDDD_ENABLED
63 : integer(IK) :: lbc
64 : #endif
65 : #elif !SLLU_ENABLED
66 : #error "Unrecognized interface."
67 : #endif
68 6598 : ubold = len(array, IK)
69 :
70 : !%%%%%%%%%
71 : #elif D1_ENABLED
72 : !%%%%%%%%%
73 :
74 : #define ALL(X) X
75 : #define GET_SHAPE(X)shape(X, IK)
76 : #define SET_DIM(OBJECT) OBJECT(lb : ub)
77 : #define ARRAY_SLICE array(lbcold : ubcold)
78 : #define TEMP_SLICE temp(lbc : lbc - lbcold + ubcold)
79 : #if setResized_ENABLED || setRefilled_ENABLED
80 : integer(IK) :: ub
81 : #endif
82 : integer(IK) :: lbold, ubold
83 : #if SLDD_ENABLED || SDDD_ENABLED || DDDD_ENABLED
84 : integer(IK) :: lbcold, ubcold
85 : #if SDDD_ENABLED || DDDD_ENABLED
86 : integer(IK) :: lbc
87 : #endif
88 : #elif !SLLU_ENABLED
89 : #error "Unrecognized interface."
90 : #endif
91 : #define GET_BOUND(BOUND, X) BOUND(X, 1, kind = IK)
92 :
93 : !%%%%%%%%%%%%%%%%%%%%%%%
94 : #elif D2_ENABLED || D3_ENABLED
95 : !%%%%%%%%%%%%%%%%%%%%%%%
96 :
97 : #define GET_SHAPE(X)shape(X, IK)
98 : #if setResized_ENABLED || setRefilled_ENABLED
99 : integer(IK) :: ub(rank(array))
100 : #endif
101 : integer(IK) :: lbold(rank(array)), ubold(rank(array))
102 : #if SLDD_ENABLED || SDDD_ENABLED || DDDD_ENABLED
103 : integer(IK) :: lbcold(rank(array)), ubcold(rank(array))
104 : #if SDDD_ENABLED || DDDD_ENABLED
105 : integer(IK) :: lbc(rank(array))
106 : #endif
107 : #elif !SLLU_ENABLED
108 : #error "Unrecognized interface."
109 : #endif
110 : #define GET_BOUND(BOUND, X) BOUND(X, kind = IK)
111 : #if D2_ENABLED
112 : #define SET_DIM(OBJECT) OBJECT(lb(1) : ub(1), lb(2) : ub(2))
113 : #define ARRAY_SLICE array(lbcold(1) : ubcold(1), lbcold(2) : ubcold(2))
114 : #define TEMP_SLICE temp(lbc(1) : lbc(1) - lbcold(1) + ubcold(1), lbc(2) : lbc(2) - lbcold(2) + ubcold(2))
115 : #elif D3_ENABLED
116 : #define SET_DIM(OBJECT) OBJECT(lb(1) : ub(1), lb(2) : ub(2), lb(3) : ub(3))
117 : #define ARRAY_SLICE array(lbcold(1) : ubcold(1), lbcold(2) : ubcold(2), lbcold(3) : ubcold(3))
118 : #define TEMP_SLICE temp(lbc(1) : lbc(1) - lbcold(1) + ubcold(1), lbc(2) : lbc(2) - lbcold(2) + ubcold(2), lbc(3) : lbc(3) - lbcold(3) + ubcold(3))
119 : #else
120 : #error "Unrecognized interface."
121 : #endif
122 : #else
123 : !%%%%%%%%%%%%%%%%%%%%%%%%
124 : #error "Unrecognized interface."
125 : !%%%%%%%%%%%%%%%%%%%%%%%%
126 : #endif
127 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
128 : ! Bypass the gfortran allocation statement error for objects of type `character` of non-zero rank.
129 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
130 :
131 : #if SK_ENABLED && !D0_ENABLED && __GFORTRAN__
132 : #define TYPE_OF_ARRAY character(len(array,IK),SKC) ::
133 : #else
134 : #define TYPE_OF_ARRAY
135 : #endif
136 : ! Check the consistency of the fill length with the string array elements length.
137 : #if SK_ENABLED && !D0_ENABLED && (setRefilled_ENABLED || setRebilled_ENABLED)
138 15129 : CHECK_ASSERTION(__LINE__, len(fill, IK) <= len(array, IK), PROCEDURE_NAME//SK_": The condition `len(fill) <= len(array)` must hold. len(fill), len(array) = "//getStr([len(fill, IK), len(array, IK)]))
139 : #endif
140 : ! Define the allocation statement.
141 : !#define SET_ALLOCATION(OBJECT) \
142 : !if (present(failed)) then; \
143 : !allocate(SET_DIM(OBJECT), stat); \
144 : !if (stat /= 0) return; \
145 : !else; \
146 : !allocate(SET_DIM(OBJECT)); \
147 : !end if;
148 : !%%%%%%%%%%%
149 : #if SDDD_ENABLED
150 : !%%%%%%%%%%%
151 :
152 : ! Check the allocation status.
153 278641 : if (.not. allocated(array)) then
154 : #if setResized_ENABLED || setRefilled_ENABLED
155 : #if !D0_ENABLED
156 66681 : lb = 1_IK
157 : #endif
158 249 : ub = size
159 : #endif
160 : !SET_ALLOCATION(array)
161 120254 : if (present(failed)) then
162 629 : if (present(errmsg)) then
163 907 : allocate(TYPE_OF_ARRAY SET_DIM(array), stat = stat, errmsg = errmsg)
164 : else
165 593 : allocate(TYPE_OF_ARRAY SET_DIM(array), stat = stat)
166 : end if
167 629 : failed = logical(stat /= 0, LK)
168 : if (failed) return ! LCOV_EXCL_LINE
169 : else
170 177268 : allocate(TYPE_OF_ARRAY SET_DIM(array))
171 : end if
172 : #if setRefilled_ENABLED && D0_ENABLED
173 : block
174 : integer(IK) :: i
175 4 : do concurrent(i = 1 : len(array, IK))
176 30 : array(i:i) = fill
177 : end do
178 : end block
179 : #elif setRefilled_ENABLED || setRebilled_ENABLED
180 3383534 : array = fill
181 : #elif !(setResized_ENABLED || setRebound_ENABLED)
182 : #error "Unrecognized interface."
183 : #endif
184 116921 : return
185 : end if
186 :
187 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
188 : #elif DDDD_ENABLED || SLDD_ENABLED || SLLU_ENABLED
189 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
190 :
191 165169 : CHECK_ASSERTION(__LINE__, allocated(array), PROCEDURE_NAME//SK_": The condition `allocated(array)` must hold.")
192 : #if setRefilled_ENABLED && D0_ENABLED && SK_ENABLED
193 1740 : CHECK_ASSERTION(__LINE__, len(fill) <= len(array), PROCEDURE_NAME//SK_": The condition `len(fill) <= len(array)` must hold. len(fill), len(array) = "//getStr([len(fill), len(array)]))
194 : #endif
195 : #else
196 : !%%%%%%%%%%%%%%%%%%%%%%%%
197 : #error "Unrecognized interface."
198 : !%%%%%%%%%%%%%%%%%%%%%%%%
199 : #endif
200 :
201 : #if !D0_ENABLED
202 657032 : lbold = GET_BOUND(lbound, array)
203 657032 : ubold = GET_BOUND(ubound, array)
204 : #endif
205 : ! Set the new upper bound of `array` for `setResized` and `setRefilled`.
206 : #if DDDD_ENABLED && (setResized_ENABLED || setRefilled_ENABLED)
207 7478 : CHECK_ASSERTION(__LINE__, all([0_IK < GET_SHAPE(array)]), PROCEDURE_NAME//SK_": The condition `all([0 < len/shape(array))` must hold when the input argument `size` is missing. len/shape(array) = "//getStr(GET_SHAPE(array)))
208 5480 : ub = lbold - 1_IK + 2_IK * (ubold - lbold + 1_IK)
209 : #elif setResized_ENABLED || setRefilled_ENABLED
210 223841 : ub = lbold - 1_IK + size
211 : #endif
212 : ! Check or set the old contents bounds and new contents offset.
213 : #if SLLU_ENABLED
214 : ! Check the contents offset.
215 : ! \bug Bypass the Intel compiler bug in processing multiple `CHECK_ASSERTION`
216 : ! macros in a single routine in `debug` compile mode by merging all `CHECK_ASSERTION` macros.
217 2010532 : CHECK_ASSERTION(__LINE__, ALL(lbold <= lbcold .and. lbcold <= ubold), PROCEDURE_NAME//SK_": The condition `all(lbound(array) <= lbcold .and. lbcold <= ubound(array))` must hold. rank(array), lbound(array), lbcold, ubound(array) = "//getStr([int(rank(array), IK), lbold, lbcold, ubold]))
218 2010532 : CHECK_ASSERTION(__LINE__, ALL(lbold <= ubcold .and. ubcold <= ubold), PROCEDURE_NAME//SK_": The condition `all(lbound(array) <= ubcold .and. ubcold <= ubound(array))` must hold. rank(array), lbound(array), ubcold, ubound(array) = "//getStr([int(rank(array), IK), lbold, ubcold, ubold]))
219 : #elif SLDD_ENABLED
220 43414 : lbcold = max(lbold, lb)
221 43414 : ubcold = lbcold + min(ubold - lbcold, ub - lbc)
222 : ! Check the contents lower bound.
223 : ! \bug Bypass the Intel compiler bug in processing multiple `CHECK_ASSERTION`
224 : ! macros in a single routine in `debug` compile mode by merging all `CHECK_ASSERTION` macros.
225 227748 : CHECK_ASSERTION(__LINE__, ALL(lb <= lbc), PROCEDURE_NAME//SK_": The condition `all(lb <= lbc)` must hold where `lb` is the lower bound of the output `array`. rank(array), lb, lbc = "//getStr([int(rank(array), IK), lb, lbc]))
226 374988 : CHECK_ASSERTION(__LINE__, ALL(lbc - lbcold + ubcold <= ub), PROCEDURE_NAME//SK_": The condition `all(lbc - lbcold + ubcold <= ub)` must hold with `ub` as the output `array` ubound. rank(array), lbc, lbcold, ubcold, ub = "//getStr([int(rank(array), IK), lbc, lbcold, ubcold, ub]))
227 : #else
228 114774 : lbcold = max(lbold, lb)
229 114774 : ubcold = min(ubold, ub)
230 15442 : lbc = lbcold
231 : #endif
232 : ! Check the output `array` size.
233 2376971 : CHECK_ASSERTION(__LINE__, ALL(0_IK <= ub - lb + 1_IK), PROCEDURE_NAME//SK_": The condition `all(0_IK <= ub - lb + 1_IK)` must hold where `lb, ub` are the lower and upper bounds of the output `array`. lb, ub = "//getStr([lb, ub]))
234 : !SET_ALLOCATION(temp)
235 323556 : if (present(failed)) then
236 94933 : if (present(errmsg)) then
237 121235 : allocate(TYPE_OF_ARRAY SET_DIM(temp), stat = stat, errmsg = errmsg)
238 : else
239 119608 : allocate(TYPE_OF_ARRAY SET_DIM(temp), stat = stat)
240 : end if
241 94933 : failed = logical(stat /= 0, LK)
242 : if (failed) return ! LCOV_EXCL_LINE
243 : else
244 424910 : allocate(TYPE_OF_ARRAY SET_DIM(temp))
245 : end if
246 : ! Copy contents.
247 : #if setResized_ENABLED || setRebound_ENABLED
248 13094343 : TEMP_SLICE = ARRAY_SLICE
249 : #elif setRefilled_ENABLED || setRebilled_ENABLED
250 1701648 : call setCoreHalo(temp, ARRAY_SLICE, fill, lbc - lb)
251 : #else
252 : #error "Unrecognized interface."
253 : #endif
254 323611 : call move_alloc(from = temp, to = array)
255 : #undef SET_ALLOCATION
256 : #undef TYPE_OF_ARRAY
257 : #undef ARRAY_SLICE
258 : #undef TEMP_SLICE
259 : #undef GET_SHAPE
260 : #undef GET_BOUND
261 : #undef SET_DIM
262 : #undef lbcold
263 : #undef ubcold
264 : #undef SIZE
265 : #undef lbc
266 : #undef ALL
267 : #undef lb
|
