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 3 : 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 3 : dummy = a
96 3 : a = b
97 3 : b = dummy
98 3 : end subroutine swap_CK
99 :
100 3 : 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 3 : use Constants_mod, only: RK
105 : implicit none
106 : real(RK), intent(inout) :: a,b
107 3 : real(RK) :: dummy
108 3 : dummy = a
109 3 : a = b
110 3 : b = dummy
111 3 : end subroutine swap_RK
112 :
113 3 : 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 3 : use Constants_mod, only: IK
118 : implicit none
119 : integer(IK), intent(inout) :: a,b
120 : integer(IK) :: dummy
121 3 : dummy = a
122 3 : a = b
123 3 : b = dummy
124 3 : end subroutine swap_IK
125 :
126 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
127 :
128 205424 : 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 3 : use Constants_mod, only: SPI
133 : implicit none
134 : integer(SPI), intent(inout) :: a,b
135 : integer(SPI) :: dum
136 205424 : dum=a
137 205424 : a=b
138 205424 : b=dum
139 205424 : end subroutine swap_SPI
140 :
141 3 : 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 205424 : use Constants_mod, only: DPI
146 : implicit none
147 : integer(DPI), intent(inout) :: a,b
148 : integer(DPI) :: dum
149 3 : dum=a
150 3 : a=b
151 3 : b=dum
152 3 : end subroutine swap_DPI
153 :
154 3 : 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 3 : use Constants_mod, only: SPR
159 : implicit none
160 : real(SPR), intent(inout) :: a,b
161 3 : real(SPR) :: dum
162 3 : dum=a
163 3 : a=b
164 3 : b=dum
165 3 : end subroutine swap_SPR
166 :
167 280 : 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 3 : use Constants_mod, only: DPR
172 : implicit none
173 : real(DPR), intent(inout) :: a,b
174 280 : real(DPR) :: dum
175 280 : dum=a
176 280 : a=b
177 280 : b=dum
178 280 : 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 3 : 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 280 : use Constants_mod, only: SPC
195 : implicit none
196 : complex(SPC), intent(inout) :: a,b
197 3 : complex(SPC) :: dum
198 3 : dum=a
199 3 : a=b
200 3 : b=dum
201 3 : end subroutine swap_SPC
202 :
203 1438230 : 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 3 : use Constants_mod, only: DPC
208 : implicit none
209 : complex(DPC), intent(inout) :: a,b
210 : complex(DPC) :: dum
211 1438230 : dum=a
212 1438230 : a=b
213 1438230 : b=dum
214 1438230 : 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 2 : 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 1438230 : use Constants_mod, only: SPR
271 : implicit none
272 : real(SPR), intent(inout) :: a,b
273 : logical, intent(in) :: mask
274 2 : real(SPR) :: swp
275 2 : if (mask) then
276 1 : swp=a
277 1 : a=b
278 1 : b=swp
279 : end if
280 2 : end subroutine masked_swap_SPR
281 :
282 2 : 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 2 : use Constants_mod, only: SPR
287 : implicit none
288 : real(SPR), dimension(:), intent(inout) :: a,b
289 : logical, dimension(:), intent(in) :: mask
290 4 : real(SPR), dimension(size(a)) :: swp
291 16 : where (mask)
292 1 : swp=a
293 1 : a=b
294 1 : b=swp
295 : end where
296 1 : end subroutine masked_swap_SPRV
297 :
298 2 : 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 1 : use Constants_mod, only: SPR
303 : implicit none
304 : real(SPR), dimension(:,:), intent(inout) :: a,b
305 : logical, dimension(:,:), intent(in) :: mask
306 9 : real(SPR), dimension(size(a,1),size(a,2)) :: swp
307 36 : where (mask)
308 1 : swp=a
309 1 : a=b
310 1 : b=swp
311 : end where
312 1 : end subroutine masked_swap_SPRM
313 :
314 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
315 :
316 : !> \brief
317 : !> Return an arithmetic progression as an array
318 36 : 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 1 : 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 2 : real(RK) :: temp
329 2 : if (n > 0) arth(1)=first
330 2 : if (n <= NPAR_ARTH) then
331 10 : do k = 2,n
332 10 : arth(k) = arth(k-1) + increment
333 : end do
334 : else
335 8 : do k = 2, NPAR2_ARTH
336 8 : arth(k) = arth(k-1) + increment
337 : end do
338 1 : temp = increment * NPAR2_ARTH
339 1 : k = NPAR2_ARTH
340 2 : do
341 3 : if (k >= n) exit
342 2 : k2 = k+k
343 26 : arth(k+1:min(k2,n)) = temp + arth(1:min(k,n-k))
344 2 : temp = temp + temp
345 2 : k = k2
346 : end do
347 : end if
348 2 : end function arth_RK
349 :
350 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
351 :
352 : !> \brief
353 : !> Return an arithmetic progression as an array.
354 1486 : 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 2 : 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 743 : if (n > 0) arth(1) = first
364 743 : if (n <= NPAR_ARTH) then
365 1714 : do k=2,n
366 1714 : arth(k) = arth(k-1) + increment
367 : end do
368 : else
369 4904 : do k = 2, NPAR2_ARTH
370 4904 : arth(k) = arth(k-1) + increment
371 : end do
372 613 : temp = increment * NPAR2_ARTH
373 613 : k = NPAR2_ARTH
374 1710 : do
375 2323 : if (k >= n) exit
376 1710 : k2 = k + k
377 78126 : arth(k+1:min(k2,n)) = temp+arth(1:min(k,n-k))
378 1710 : temp = temp + temp
379 1710 : k = k2
380 : end do
381 : end if
382 743 : end function arth_IK
383 :
384 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
385 :
386 : !> \brief
387 : !> Return `nn` consecutive powers of the `n`th root of unity.
388 1478 : 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 743 : 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 739 : real(RK) :: theta
398 739 : zroots_unity(1) = 1._RK
399 739 : theta = TWOPI / n
400 739 : k = 1
401 5956 : do
402 6695 : if (k >= nn) exit
403 5956 : zroots_unity(k+1) = cmplx(cos(k*theta),sin(k*theta),kind=RK)
404 1665410 : zroots_unity(k+2:min(2*k,nn)) = zroots_unity(k+1) * zroots_unity(2:min(k,nn-k))
405 5956 : k = 2 * k
406 : end do
407 739 : end function zroots_unity
408 :
409 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
410 :
411 4 : 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 739 : 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 2 : numCopied = min(size(Source),size(Destination))
421 2 : numNotCopied = size(Source) - numCopied
422 12 : Destination(1:numCopied) = Source(1:numCopied)
423 2 : end subroutine copyArray_IK
424 :
425 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
426 :
427 4 : 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 2 : 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 2 : numCopied = min(size(Source),size(Destination))
437 2 : numNotCopied = size(Source) - numCopied
438 12 : Destination(1:numCopied) = Source(1:numCopied)
439 2 : 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 4 : 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 2 : 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 4 : allocate(UniqueValue(lenVector))
465 211 : allocate(UniqueCount(lenVector), source = 0_IK)
466 4 : lenUniq = 0
467 211 : do i = 1, lenVector
468 207 : isUnique = .true.
469 907 : loopSearchUnique: do j = 1, lenUniq
470 907 : if (UniqueValue(j)==Vector(i)) then
471 187 : UniqueCount(j) = UniqueCount(j) + 1
472 187 : isUnique = .false.
473 187 : exit loopSearchUnique
474 : end if
475 : end do loopSearchUnique
476 211 : if (isUnique) then
477 20 : lenUniq = lenUniq + 1
478 20 : UniqueValue(lenUniq) = Vector(i)
479 20 : UniqueCount(lenUniq) = UniqueCount(lenUniq) + 1
480 : end if
481 : end do
482 45 : UniqueValue = UniqueValue(1:lenUniq)
483 45 : UniqueCount = UniqueCount(1:lenUniq)
484 4 : if (present(lenUnique)) lenUnique = lenUniq
485 4 : 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 7 : 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 4 : 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 7 : allocate(Temp(to))
505 236 : Temp(1:from) = Vector
506 7 : call move_alloc(Temp, Vector)
507 7 : end subroutine resizeVector_RK
508 :
509 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
510 :
511 : end module Misc_mod
|
