Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!!
4 : !!!! MIT License
5 : !!!!
6 : !!!! ParaMonte: plain powerful parallel Monte Carlo library.
7 : !!!!
8 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab
9 : !!!!
10 : !!!! This file is part of the ParaMonte library.
11 : !!!!
12 : !!!! Permission is hereby granted, free of charge, to any person obtaining a
13 : !!!! copy of this software and associated documentation files (the "Software"),
14 : !!!! to deal in the Software without restriction, including without limitation
15 : !!!! the rights to use, copy, modify, merge, publish, distribute, sublicense,
16 : !!!! and/or sell copies of the Software, and to permit persons to whom the
17 : !!!! Software is furnished to do so, subject to the following conditions:
18 : !!!!
19 : !!!! The above copyright notice and this permission notice shall be
20 : !!!! included in all copies or substantial portions of the Software.
21 : !!!!
22 : !!!! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
23 : !!!! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
24 : !!!! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
25 : !!!! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
26 : !!!! DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
27 : !!!! OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
28 : !!!! OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
29 : !!!!
30 : !!!! ACKNOWLEDGMENT
31 : !!!!
32 : !!!! ParaMonte is an honor-ware and its currency is acknowledgment and citations.
33 : !!!! As per the ParaMonte library license agreement terms, if you use any parts of
34 : !!!! this library for any purposes, kindly acknowledge the use of ParaMonte in your
35 : !!!! work (education/research/industry/development/...) by citing the ParaMonte
36 : !!!! library as described on this page:
37 : !!!!
38 : !!!! https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
39 : !!!!
40 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
41 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
42 :
43 : !> \brief This module contains miscellaneous procedures.
44 : !> \author Amir Shahmoradi
45 :
46 : module Misc_mod
47 :
48 : use, intrinsic :: iso_fortran_env, only: int32
49 : implicit none
50 :
51 : character(*), parameter :: MODULE_NAME = "@Misc_mod"
52 :
53 : integer(int32), PARAMETER :: NPAR_ARTH = 16_int32, NPAR2_ARTH = 8_int32
54 :
55 : interface copyArray
56 : module procedure :: copyArray_IK, copyArray_RK
57 : end interface copyArray
58 :
59 : interface arth
60 : module procedure :: arth_RK, arth_IK
61 : end interface arth
62 :
63 : interface swap
64 : !module procedure :: swap_CK, swap_RK, swap_IK !, swap_vec_RK
65 : module procedure :: swap_SPI, swap_DPI, swap_SPR, swap_DPR, swap_SPC, swap_DPC ! , swap_cm, swap_z, swap_rv, swap_cv
66 : module procedure :: masked_swap_SPR, masked_swap_SPRV, masked_swap_SPRM ! swap_zv, swap_zm
67 : end interface swap
68 :
69 : interface findUnique
70 : module procedure :: findUnique_IK
71 : end interface findUnique
72 :
73 : interface resize
74 : module procedure :: resizeVector_RK
75 : end interface resize
76 :
77 : interface resizeVector
78 : module procedure :: resizeVector_RK
79 : end interface resizeVector
80 :
81 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
82 :
83 : contains
84 :
85 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
86 :
87 9 : pure elemental subroutine swap_CK(a,b)
88 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
89 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_CK
90 : #endif
91 : use Constants_mod, only: CK
92 : implicit none
93 : complex(CK), intent(inout) :: a,b
94 : complex(CK) :: dummy
95 9 : dummy = a
96 9 : a = b
97 9 : b = dummy
98 9 : end subroutine swap_CK
99 :
100 9 : pure elemental subroutine swap_RK(a,b)
101 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
102 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_RK
103 : #endif
104 9 : use Constants_mod, only: RK
105 : implicit none
106 : real(RK), intent(inout) :: a,b
107 9 : real(RK) :: dummy
108 9 : dummy = a
109 9 : a = b
110 9 : b = dummy
111 9 : end subroutine swap_RK
112 :
113 9 : pure elemental subroutine swap_IK(a,b)
114 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
115 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_IK
116 : #endif
117 9 : use Constants_mod, only: IK
118 : implicit none
119 : integer(IK), intent(inout) :: a,b
120 : integer(IK) :: dummy
121 9 : dummy = a
122 9 : a = b
123 9 : b = dummy
124 9 : end subroutine swap_IK
125 :
126 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
127 :
128 287805 : pure elemental subroutine swap_SPI(a,b)
129 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
130 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_SPI
131 : #endif
132 9 : use Constants_mod, only: SPI
133 : implicit none
134 : integer(SPI), intent(inout) :: a,b
135 : integer(SPI) :: dum
136 287805 : dum=a
137 287805 : a=b
138 287805 : b=dum
139 287805 : end subroutine swap_SPI
140 :
141 9 : pure elemental subroutine swap_DPI(a,b)
142 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
143 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_DPI
144 : #endif
145 287805 : use Constants_mod, only: DPI
146 : implicit none
147 : integer(DPI), intent(inout) :: a,b
148 : integer(DPI) :: dum
149 9 : dum=a
150 9 : a=b
151 9 : b=dum
152 9 : end subroutine swap_DPI
153 :
154 9 : pure elemental subroutine swap_SPR(a,b)
155 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
156 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_SPR
157 : #endif
158 9 : use Constants_mod, only: SPR
159 : implicit none
160 : real(SPR), intent(inout) :: a,b
161 9 : real(SPR) :: dum
162 9 : dum=a
163 9 : a=b
164 9 : b=dum
165 9 : end subroutine swap_SPR
166 :
167 1606460 : pure elemental subroutine swap_DPR(a,b)
168 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
169 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_DPR
170 : #endif
171 9 : use Constants_mod, only: DPR
172 : implicit none
173 : real(DPR), intent(inout) :: a,b
174 1606460 : real(DPR) :: dum
175 1606460 : dum=a
176 1606460 : a=b
177 1606460 : b=dum
178 1606460 : end subroutine swap_DPR
179 :
180 : !pure subroutine swap_rv(a,b)
181 : ! use Constants_mod, only: SPR
182 : ! implicit none
183 : ! real(SPR), dimension(:), intent(inout) :: a,b
184 : ! real(SPR), dimension(size(a)) :: dum
185 : ! dum=a
186 : ! a=b
187 : ! b=dum
188 : !end subroutine swap_rv
189 :
190 9 : pure elemental subroutine swap_SPC(a,b)
191 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
192 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_SPC
193 : #endif
194 1606460 : use Constants_mod, only: SPC
195 : implicit none
196 : complex(SPC), intent(inout) :: a,b
197 9 : complex(SPC) :: dum
198 9 : dum=a
199 9 : a=b
200 9 : b=dum
201 9 : end subroutine swap_SPC
202 :
203 4395530 : pure elemental subroutine swap_DPC(a,b)
204 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
205 : !DEC$ ATTRIBUTES DLLEXPORT :: swap_DPC
206 : #endif
207 9 : use Constants_mod, only: DPC
208 : implicit none
209 : complex(DPC), intent(inout) :: a,b
210 : complex(DPC) :: dum
211 4395530 : dum=a
212 4395530 : a=b
213 4395530 : b=dum
214 4395530 : end subroutine swap_DPC
215 :
216 : !pure subroutine swap_cv(a,b)
217 : ! use Constants_mod, only: SPC
218 : ! implicit none
219 : ! complex(SPC), dimension(:), intent(inout) :: a,b
220 : ! complex(SPC), dimension(size(a)) :: dum
221 : ! dum=a
222 : ! a=b
223 : ! b=dum
224 : !end subroutine swap_cv
225 :
226 : !pure subroutine swap_cm(a,b)
227 : ! use Constants_mod, only: SPC
228 : ! implicit none
229 : ! complex(SPC), dimension(:,:), intent(inout) :: a,b
230 : ! complex(SPC), dimension(size(a,1),size(a,2)) :: dum
231 : ! dum=a
232 : ! a=b
233 : ! b=dum
234 : !end subroutine swap_cm
235 :
236 : !pure subroutine swap_z(a,b)
237 : ! use Constants_mod, only: DPC
238 : ! implicit none
239 : ! complex(DPC), intent(inout) :: a,b
240 : ! complex(DPC) :: dum
241 : ! dum=a
242 : ! a=b
243 : ! b=dum
244 : !end subroutine swap_z
245 :
246 : !pure subroutine swap_zv(a,b)
247 : ! use Constants_mod, only: DPC
248 : ! implicit none
249 : ! complex(DPC), dimension(:), intent(inout) :: a,b
250 : ! complex(DPC), dimension(size(a)) :: dum
251 : ! dum=a
252 : ! a=b
253 : ! b=dum
254 : !end subroutine swap_zv
255 :
256 : !pure subroutine swap_zm(a,b)
257 : ! use Constants_mod, only: DPC
258 : ! implicit none
259 : ! complex(DPC), dimension(:,:), intent(inout) :: a,b
260 : ! complex(DPC), dimension(size(a,1),size(a,2)) :: dum
261 : ! dum=a
262 : ! a=b
263 : ! b=dum
264 : !end subroutine swap_zm
265 :
266 6 : pure subroutine masked_swap_SPR(a,b,mask)
267 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
268 : !DEC$ ATTRIBUTES DLLEXPORT :: masked_swap_SPR
269 : #endif
270 4395530 : use Constants_mod, only: SPR
271 : implicit none
272 : real(SPR), intent(inout) :: a,b
273 : logical, intent(in) :: mask
274 6 : real(SPR) :: swp
275 6 : if (mask) then
276 3 : swp=a
277 3 : a=b
278 3 : b=swp
279 : end if
280 6 : end subroutine masked_swap_SPR
281 :
282 6 : pure subroutine masked_swap_SPRV(a,b,mask)
283 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
284 : !DEC$ ATTRIBUTES DLLEXPORT :: masked_swap_SPRV
285 : #endif
286 6 : use Constants_mod, only: SPR
287 : implicit none
288 : real(SPR), dimension(:), intent(inout) :: a,b
289 : logical, dimension(:), intent(in) :: mask
290 12 : real(SPR), dimension(size(a)) :: swp
291 48 : where (mask)
292 3 : swp=a
293 3 : a=b
294 3 : b=swp
295 : end where
296 3 : end subroutine masked_swap_SPRV
297 :
298 6 : pure subroutine masked_swap_SPRM(a,b,mask)
299 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
300 : !DEC$ ATTRIBUTES DLLEXPORT :: masked_swap_SPRM
301 : #endif
302 3 : use Constants_mod, only: SPR
303 : implicit none
304 : real(SPR), dimension(:,:), intent(inout) :: a,b
305 : logical, dimension(:,:), intent(in) :: mask
306 27 : real(SPR), dimension(size(a,1),size(a,2)) :: swp
307 108 : where (mask)
308 3 : swp=a
309 3 : a=b
310 3 : b=swp
311 : end where
312 3 : end subroutine masked_swap_SPRM
313 :
314 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
315 :
316 : !> \brief
317 : !> Return an arithmetic progression as an array
318 108 : pure function arth_RK(first,increment,n) result(arth)
319 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
320 : !DEC$ ATTRIBUTES DLLEXPORT :: arth_RK
321 : #endif
322 3 : use Constants_mod, only: IK, RK
323 : implicit none
324 : real(RK) , intent(in) :: first,increment
325 : integer(IK) , intent(in) :: n
326 : real(RK) :: arth(n)
327 : integer(IK) :: k,k2
328 6 : real(RK) :: temp
329 6 : if (n > 0) arth(1)=first
330 6 : if (n <= NPAR_ARTH) then
331 30 : do k = 2,n
332 30 : arth(k) = arth(k-1) + increment
333 : end do
334 : else
335 24 : do k = 2, NPAR2_ARTH
336 24 : arth(k) = arth(k-1) + increment
337 : end do
338 3 : temp = increment * NPAR2_ARTH
339 3 : k = NPAR2_ARTH
340 6 : do
341 9 : if (k >= n) exit
342 6 : k2 = k+k
343 78 : arth(k+1:min(k2,n)) = temp + arth(1:min(k,n-k))
344 6 : temp = temp + temp
345 6 : k = k2
346 : end do
347 : end if
348 6 : end function arth_RK
349 :
350 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
351 :
352 : !> \brief
353 : !> Return an arithmetic progression as an array.
354 3504 : pure function arth_IK(first,increment,n) result(arth)
355 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
356 : !DEC$ ATTRIBUTES DLLEXPORT :: arth_IK
357 : #endif
358 6 : use Constants_mod, only: IK, RK
359 : implicit none
360 : integer(IK) , intent(in) :: first,increment,n
361 : integer(IK) :: arth(n)
362 : integer(IK) :: k,k2,temp
363 1752 : if (n > 0) arth(1) = first
364 1752 : if (n <= NPAR_ARTH) then
365 3594 : do k=2,n
366 3594 : arth(k) = arth(k-1) + increment
367 : end do
368 : else
369 11544 : do k = 2, NPAR2_ARTH
370 11544 : arth(k) = arth(k-1) + increment
371 : end do
372 1443 : temp = increment * NPAR2_ARTH
373 1443 : k = NPAR2_ARTH
374 4374 : do
375 5817 : if (k >= n) exit
376 4374 : k2 = k + k
377 223830 : arth(k+1:min(k2,n)) = temp+arth(1:min(k,n-k))
378 4374 : temp = temp + temp
379 4374 : k = k2
380 : end do
381 : end if
382 1752 : end function arth_IK
383 :
384 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
385 :
386 : !> \brief
387 : !> Return `nn` consecutive powers of the `n`th root of unity.
388 3480 : pure function zroots_unity(n,nn)
389 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
390 : !DEC$ ATTRIBUTES DLLEXPORT :: zroots_unity
391 : #endif
392 1752 : use Constants_mod, only: IK, RK, CK, TWOPI
393 : implicit none
394 : integer(IK), intent(in) :: n, nn
395 : complex(CK) :: zroots_unity(nn)
396 : integer(IK) :: k
397 1740 : real(RK) :: theta
398 1740 : zroots_unity(1) = 1._RK
399 1740 : theta = TWOPI / n
400 1740 : k = 1
401 14538 : do
402 16278 : if (k >= nn) exit
403 14538 : zroots_unity(k+1) = cmplx(cos(k*theta),sin(k*theta),kind=RK)
404 5078170 : zroots_unity(k+2:min(2*k,nn)) = zroots_unity(k+1) * zroots_unity(2:min(k,nn-k))
405 14538 : k = 2 * k
406 : end do
407 1740 : end function zroots_unity
408 :
409 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
410 :
411 12 : pure subroutine copyArray_IK(Source,Destination,numCopied,numNotCopied)
412 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
413 : !DEC$ ATTRIBUTES DLLEXPORT :: copyArray_IK
414 : #endif
415 1740 : use Constants_mod, only: IK
416 : implicit none
417 : integer(IK), intent(in) :: Source(:)
418 : integer(IK), intent(out) :: Destination(:)
419 : integer(IK), intent(out) :: numCopied, numNotCopied
420 6 : numCopied = min(size(Source),size(Destination))
421 6 : numNotCopied = size(Source) - numCopied
422 36 : Destination(1:numCopied) = Source(1:numCopied)
423 6 : end subroutine copyArray_IK
424 :
425 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
426 :
427 12 : pure subroutine copyArray_RK(Source,Destination,numCopied,numNotCopied)
428 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
429 : !DEC$ ATTRIBUTES DLLEXPORT :: copyArray_RK
430 : #endif
431 6 : use Constants_mod, only: IK, RK
432 : implicit none
433 : real(RK), intent(in) :: Source(:)
434 : real(RK), intent(out) :: Destination(:)
435 : integer(IK), intent(out) :: numCopied, numNotCopied
436 6 : numCopied = min(size(Source),size(Destination))
437 6 : numNotCopied = size(Source) - numCopied
438 36 : Destination(1:numCopied) = Source(1:numCopied)
439 6 : end subroutine copyArray_RK
440 :
441 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
442 :
443 : !> \brief
444 : !> Find the unique values in the input integer vector.
445 : !>
446 : !> @param[in] lenVector : The size of the input square matrix - `nd` by `nd`.
447 : !> @param[in] Vector : The input integer vector.
448 : !> @param[out] UniqueValue : The vector of unique values identified in the input vector.
449 : !> @param[out] UniqueCount : The counts of each unique value in the input vector.
450 : !> @param[out] lenUnique : The length of `UniqueValue`, that is, the total number of unique values.
451 221 : pure subroutine findUnique_IK(lenVector, Vector, UniqueValue, UniqueCount, lenUnique)
452 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
453 : !DEC$ ATTRIBUTES DLLEXPORT :: findUnique_IK
454 : #endif
455 6 : use Constants_mod, only: IK
456 : implicit none
457 : integer(IK) , intent(in) :: lenVector
458 : integer(IK) , intent(in) :: Vector(lenVector)
459 : integer(IK) , intent(out), allocatable :: UniqueValue(:)
460 : integer(IK) , intent(out), allocatable :: UniqueCount(:)
461 : integer(IK) , intent(out), optional :: lenUnique
462 : integer(IK) :: lenUniq, i, j
463 : logical :: isUnique
464 221 : allocate(UniqueValue(lenVector))
465 68562 : allocate(UniqueCount(lenVector), source = 0_IK)
466 221 : lenUniq = 0
467 68562 : do i = 1, lenVector
468 68341 : isUnique = .true.
469 108326 : loopSearchUnique: do j = 1, lenUniq
470 108326 : if (UniqueValue(j)==Vector(i)) then
471 67658 : UniqueCount(j) = UniqueCount(j) + 1
472 67658 : isUnique = .false.
473 67658 : exit loopSearchUnique
474 : end if
475 : end do loopSearchUnique
476 68562 : if (isUnique) then
477 683 : lenUniq = lenUniq + 1
478 683 : UniqueValue(lenUniq) = Vector(i)
479 683 : UniqueCount(lenUniq) = UniqueCount(lenUniq) + 1
480 : end if
481 : end do
482 1590 : UniqueValue = UniqueValue(1:lenUniq)
483 1590 : UniqueCount = UniqueCount(1:lenUniq)
484 221 : if (present(lenUnique)) lenUnique = lenUniq
485 221 : end subroutine findUnique_IK
486 :
487 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
488 :
489 : !> \brief
490 : !> Resize the input 1-dimensional real vector to a new size.
491 : !>
492 : !> @param[inout] Vector : The input real vector that will be resized on return.
493 : !> @param[out] from : The number of elements of `Vector`.
494 : !> @param[out] to : The new size of `Vector`.
495 21 : pure subroutine resizeVector_RK(Vector, from, to)
496 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
497 : !DEC$ ATTRIBUTES DLLEXPORT :: resizeVector_RK
498 : #endif
499 221 : use Constants_mod, only: IK, RK
500 : implicit none
501 : integer(IK) , intent(in) :: from, to
502 : real(RK) , allocatable , intent(inout) :: Vector(:)
503 : real(RK) , allocatable :: Temp(:)
504 21 : allocate(Temp(to))
505 708 : Temp(1:from) = Vector
506 21 : call move_alloc(Temp, Vector)
507 21 : end subroutine resizeVector_RK
508 :
509 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
510 :
511 : end module Misc_mod
|
